Released SD*5.3*563 SEQ #492 Extracted from mail message **KIDS**:SD*5.3*563^ **INSTALL NAME** SD*5.3*563 "BLD",8237,0) SD*5.3*563^SCHEDULING^0^3120717^y "BLD",8237,1,0) ^^11^11^3120606^ "BLD",8237,1,1,0) 1. An error that occurs when un-assigning a patient with a future dated "BLD",8237,1,2,0) assignment. "BLD",8237,1,3,0) "BLD",8237,1,4,0) 2. No warning message is displayed when Assigning/Re-assigning a deceased "BLD",8237,1,5,0) patient. "BLD",8237,1,6,0) "BLD",8237,1,7,0) 3. The user has the ability to assign/unassign a deceased patient "BLD",8237,1,8,0) to a team or position after their date of death. "BLD",8237,1,9,0) "BLD",8237,1,10,0) 4. An error that occurs when a user enters "^^" at the prompt "Enter response: "BLD",8237,1,11,0) 1//" using the PCMM Assign or Unassign protocol. "BLD",8237,4,0) ^9.64PA^^ "BLD",8237,6) 4^ "BLD",8237,6.3) 45 "BLD",8237,"KRN",0) ^9.67PA^779.2^20 "BLD",8237,"KRN",.4,0) .4 "BLD",8237,"KRN",.401,0) .401 "BLD",8237,"KRN",.402,0) .402 "BLD",8237,"KRN",.403,0) .403 "BLD",8237,"KRN",.5,0) .5 "BLD",8237,"KRN",.84,0) .84 "BLD",8237,"KRN",3.6,0) 3.6 "BLD",8237,"KRN",3.8,0) 3.8 "BLD",8237,"KRN",9.2,0) 9.2 "BLD",8237,"KRN",9.8,0) 9.8 "BLD",8237,"KRN",9.8,"NM",0) ^9.68A^5^4 "BLD",8237,"KRN",9.8,"NM",2,0) SCMCQK^^0^B21155109 "BLD",8237,"KRN",9.8,"NM",3,0) SCMCMU2^^0^B72023784 "BLD",8237,"KRN",9.8,"NM",4,0) SCMCQK1^^0^B106090791 "BLD",8237,"KRN",9.8,"NM",5,0) SCMCQK2^^0^B59731461 "BLD",8237,"KRN",9.8,"NM","B","SCMCMU2",3) "BLD",8237,"KRN",9.8,"NM","B","SCMCQK",2) "BLD",8237,"KRN",9.8,"NM","B","SCMCQK1",4) "BLD",8237,"KRN",9.8,"NM","B","SCMCQK2",5) "BLD",8237,"KRN",19,0) 19 "BLD",8237,"KRN",19.1,0) 19.1 "BLD",8237,"KRN",101,0) 101 "BLD",8237,"KRN",409.61,0) 409.61 "BLD",8237,"KRN",771,0) 771 "BLD",8237,"KRN",779.2,0) 779.2 "BLD",8237,"KRN",870,0) 870 "BLD",8237,"KRN",8989.51,0) 8989.51 "BLD",8237,"KRN",8989.52,0) 8989.52 "BLD",8237,"KRN",8994,0) 8994 "BLD",8237,"KRN","B",.4,.4) "BLD",8237,"KRN","B",.401,.401) "BLD",8237,"KRN","B",.402,.402) "BLD",8237,"KRN","B",.403,.403) "BLD",8237,"KRN","B",.5,.5) "BLD",8237,"KRN","B",.84,.84) "BLD",8237,"KRN","B",3.6,3.6) "BLD",8237,"KRN","B",3.8,3.8) "BLD",8237,"KRN","B",9.2,9.2) "BLD",8237,"KRN","B",9.8,9.8) "BLD",8237,"KRN","B",19,19) "BLD",8237,"KRN","B",19.1,19.1) "BLD",8237,"KRN","B",101,101) "BLD",8237,"KRN","B",409.61,409.61) "BLD",8237,"KRN","B",771,771) "BLD",8237,"KRN","B",779.2,779.2) "BLD",8237,"KRN","B",870,870) "BLD",8237,"KRN","B",8989.51,8989.51) "BLD",8237,"KRN","B",8989.52,8989.52) "BLD",8237,"KRN","B",8994,8994) "BLD",8237,"QDEF") ^^^^NO^^^^NO^^YES "BLD",8237,"QUES",0) ^9.62^^ "BLD",8237,"REQB",0) ^9.611^2^1 "BLD",8237,"REQB",2,0) SD*5.3*535^2 "BLD",8237,"REQB","B","SD*5.3*535",2) "MBREQ") 0 "PKG",16,-1) 1^1 "PKG",16,0) SCHEDULING^SD^APPOINTMENTS,PROFILES,LETTERS,AMIS REPORTS "PKG",16,20,0) ^9.402P^^ "PKG",16,22,0) ^9.49I^1^1 "PKG",16,22,1,0) 5.3^2930813 "PKG",16,22,1,"PAH",1,0) 563^3120717^1197 "PKG",16,22,1,"PAH",1,1,0) ^^11^11^3120717 "PKG",16,22,1,"PAH",1,1,1,0) 1. An error that occurs when un-assigning a patient with a future dated "PKG",16,22,1,"PAH",1,1,2,0) assignment. "PKG",16,22,1,"PAH",1,1,3,0) "PKG",16,22,1,"PAH",1,1,4,0) 2. No warning message is displayed when Assigning/Re-assigning a deceased "PKG",16,22,1,"PAH",1,1,5,0) patient. "PKG",16,22,1,"PAH",1,1,6,0) "PKG",16,22,1,"PAH",1,1,7,0) 3. The user has the ability to assign/unassign a deceased patient "PKG",16,22,1,"PAH",1,1,8,0) to a team or position after their date of death. "PKG",16,22,1,"PAH",1,1,9,0) "PKG",16,22,1,"PAH",1,1,10,0) 4. An error that occurs when a user enters "^^" at the prompt "Enter response: "PKG",16,22,1,"PAH",1,1,11,0) 1//" using the PCMM Assign or Unassign protocol. "QUES","XPF1",0) Y "QUES","XPF1","??") ^D REP^XPDH "QUES","XPF1","A") Shall I write over your |FLAG| File "QUES","XPF1","B") YES "QUES","XPF1","M") D XPF1^XPDIQ "QUES","XPF2",0) Y "QUES","XPF2","??") ^D DTA^XPDH "QUES","XPF2","A") Want my data |FLAG| yours "QUES","XPF2","B") YES "QUES","XPF2","M") D XPF2^XPDIQ "QUES","XPI1",0) YO "QUES","XPI1","??") ^D INHIBIT^XPDH "QUES","XPI1","A") Want KIDS to INHIBIT LOGONs during the install "QUES","XPI1","B") NO "QUES","XPI1","M") D XPI1^XPDIQ "QUES","XPM1",0) PO^VA(200,:EM "QUES","XPM1","??") ^D MG^XPDH "QUES","XPM1","A") Enter the Coordinator for Mail Group '|FLAG|' "QUES","XPM1","B") "QUES","XPM1","M") D XPM1^XPDIQ "QUES","XPO1",0) Y "QUES","XPO1","??") ^D MENU^XPDH "QUES","XPO1","A") Want KIDS to Rebuild Menu Trees Upon Completion of Install "QUES","XPO1","B") NO "QUES","XPO1","M") D XPO1^XPDIQ "QUES","XPZ1",0) Y "QUES","XPZ1","??") ^D OPT^XPDH "QUES","XPZ1","A") Want to DISABLE Scheduled Options, Menu Options, and Protocols "QUES","XPZ1","B") YES "QUES","XPZ1","M") D XPZ1^XPDIQ "QUES","XPZ2",0) Y "QUES","XPZ2","??") ^D RTN^XPDH "QUES","XPZ2","A") Want to MOVE routines to other CPUs "QUES","XPZ2","B") NO "QUES","XPZ2","M") D XPZ2^XPDIQ "RTN") 4 "RTN","SCMCMU2") 0^3^B72023784^B69562260 "RTN","SCMCMU2",1,0) SCMCMU2 ;ALBOI/MJK - PCMM Mass Team/Position Unassignment Processing;07/10/98 ; 5/14/12 1:54pm "RTN","SCMCMU2",2,0) ;;5.3;Scheduling;**148,177,524,563**;AUG 13, 1993;Build 45 "RTN","SCMCMU2",3,0) ; "RTN","SCMCMU2",4,0) QUE() ; -- queue mass unassignment "RTN","SCMCMU2",5,0) ;D START Q 99999 ; -- for interactive testing "RTN","SCMCMU2",6,0) N ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSAVE,ZTSK "RTN","SCMCMU2",7,0) S ZTRTN="START^SCMCMU2" "RTN","SCMCMU2",8,0) S ZTDESC=VALM("TITLE") "RTN","SCMCMU2",9,0) S ZTDTH=$H "RTN","SCMCMU2",10,0) S ZTIO="" "RTN","SCMCMU2",11,0) F X="SCTEAM","SCPOS","SCTPDIS(","SCMUTYPE","SCDATE","SCSELCNT" S ZTSAVE(X)="" "RTN","SCMCMU2",12,0) F X="^TMP(""SCMU"",$J,""SELECTED"",","^TMP(""SCMU"",$J,""PATIENT INFO""," S ZTSAVE(X)="" "RTN","SCMCMU2",13,0) D ^%ZTLOAD "RTN","SCMCMU2",14,0) Q $G(ZTSK) "RTN","SCMCMU2",15,0) ; "RTN","SCMCMU2",16,0) START ; -- entry point for task "RTN","SCMCMU2",17,0) ; -- defined from task SCTEAM,SCPOS,SCTPDIS,SCMUTYPE,SCDATE,SCSELCNT "RTN","SCMCMU2",18,0) ; "RTN","SCMCMU2",19,0) N SCTOP,SCUNCNT,SCASCNT,SCOK "RTN","SCMCMU2",20,0) S SCUNCNT=0 "RTN","SCMCMU2",21,0) S SCASCNT=SCSELCNT "RTN","SCMCMU2",22,0) ; "RTN","SCMCMU2",23,0) ; -- lock top node "RTN","SCMCMU2",24,0) IF SCMUTYPE="T" D "RTN","SCMCMU2",25,0) . S SCTOP=$NA(^SCTM(404.51,+SCTEAM,0)) "RTN","SCMCMU2",26,0) ELSE IF SCMUTYPE="P" D "RTN","SCMCMU2",27,0) . S SCTOP=$NA(^SCTM(404.57,+SCPOS,0)) "RTN","SCMCMU2",28,0) D LOCK(SCTOP) "RTN","SCMCMU2",29,0) ; "RTN","SCMCMU2",30,0) ; -- use tmp data brought in by TaskMan "RTN","SCMCMU2",31,0) N SCPTSEL,SCPTINFO "RTN","SCMCMU2",32,0) S SCPTSEL=$NA(^TMP("SCMU",$J,"SELECTED")) "RTN","SCMCMU2",33,0) S SCPTINFO=$NA(^TMP("SCMU",$J,"PATIENT INFO")) "RTN","SCMCMU2",34,0) ; "RTN","SCMCMU2",35,0) N SCOKAR,SCBADAR,SCERRAR,SCPTTP "RTN","SCMCMU2",36,0) S SCOKAR=$NA(^TMP("SCMU",$J,"OK")) "RTN","SCMCMU2",37,0) S SCBADAR=$NA(^TMP("SCMU",$J,"BAD")) "RTN","SCMCMU2",38,0) S SCERRAR=$NA(^TMP("SCMU",$J,"ERROR")) "RTN","SCMCMU2",39,0) S SCPTTP=$NA(^TMP("SCMU",$J,"PATIENT-POSITION")) "RTN","SCMCMU2",40,0) K @SCOKAR,@SCBADAR,@SCERRAR,@SCPTTP "RTN","SCMCMU2",41,0) ; "RTN","SCMCMU2",42,0) N SCNT,SCNODE,SCPTX "RTN","SCMCMU2",43,0) ; "RTN","SCMCMU2",44,0) ; -- create patient-position array for team processing "RTN","SCMCMU2",45,0) IF SCMUTYPE="T" D PTTPLST^SCMCMU11(SCTEAM,SCDATE,SCPTTP) "RTN","SCMCMU2",46,0) ; "RTN","SCMCMU2",47,0) S SCNT=0 "RTN","SCMCMU2",48,0) F S SCNT=$O(@SCPTSEL@(SCNT)) Q:'SCNT D "RTN","SCMCMU2",49,0) . ;N SCDATE S SCDATE=2700101 ; -- use to force error/testing "RTN","SCMCMU2",50,0) . S SCPTX=$G(@SCPTINFO@(SCNT)) "RTN","SCMCMU2",51,0) . IF SCPTX="" Q "RTN","SCMCMU2",52,0) . IF SCMUTYPE="T" S SCOK=$$TMDIS(SCDATE,SCTEAM,SCNT,SCPTX) "RTN","SCMCMU2",53,0) . ; "RTN","SCMCMU2",54,0) . IF SCMUTYPE="P" S SCOK=$$TPDIS(SCDATE,SCPOS,SCNT,SCPTX) "RTN","SCMCMU2",55,0) . ; "RTN","SCMCMU2",56,0) . ; -- if successful "RTN","SCMCMU2",57,0) . IF SCOK D "RTN","SCMCMU2",58,0) . . S @SCOKAR@(SCNT)="" "RTN","SCMCMU2",59,0) . . S SCUNCNT=SCUNCNT+1 "RTN","SCMCMU2",60,0) . . S SCASCNT=SCASCNT-1 "RTN","SCMCMU2",61,0) . ; "RTN","SCMCMU2",62,0) . ; -- if not sucessful "RTN","SCMCMU2",63,0) . ELSE D "RTN","SCMCMU2",64,0) . . S @SCBADAR@(SCNT)="" "RTN","SCMCMU2",65,0) ; "RTN","SCMCMU2",66,0) ; -- unlock top node "RTN","SCMCMU2",67,0) D UNLOCK(SCTOP) "RTN","SCMCMU2",68,0) ; "RTN","SCMCMU2",69,0) ; -- send results "RTN","SCMCMU2",70,0) D BULL^SCMCMU4 "RTN","SCMCMU2",71,0) ; "RTN","SCMCMU2",72,0) K @SCOKAR,@SCBADAR,@SCERRAR,@SCPTTP "RTN","SCMCMU2",73,0) K @SCPTSEL,@SCPTINFO "RTN","SCMCMU2",74,0) Q "RTN","SCMCMU2",75,0) ; "RTN","SCMCMU2",76,0) ; **** May want to eventually combine TMDIS & TPDIS tags **** "RTN","SCMCMU2",77,0) ; "RTN","SCMCMU2",78,0) TMDIS(SCDATE,SCTEAM,SCNT,SCPTX) ; -- team unassignment for patient "RTN","SCMCMU2",79,0) ; input: SCDATE := effective date "RTN","SCMCMU2",80,0) ; SCTEAM := ien of TEAM entry (404.51) "RTN","SCMCMU2",81,0) ; SCNT := entry in @SCPTINFO@ & @SCPTALL@ arrays "RTN","SCMCMU2",82,0) ; SCPTX := format defined by output of $$PTTM^SCAPMC2 "RTN","SCMCMU2",83,0) ; "RTN","SCMCMU2",84,0) N SCNODE,SCPOS,SCPOSI,SCOK,SCERRS,DFN,SCIEN,SCASDT,SCUNDT "RTN","SCMCMU2",85,0) ; "RTN","SCMCMU2",86,0) S SCOK=1 "RTN","SCMCMU2",87,0) S SCERRS="SCERRLST" "RTN","SCMCMU2",88,0) ; "RTN","SCMCMU2",89,0) S DFN=+SCPTX "RTN","SCMCMU2",90,0) S SCIEN=+$P(SCPTX,U,3) "RTN","SCMCMU2",91,0) S SCNODE=$NA(^SCPT(404.42,SCIEN,0)) "RTN","SCMCMU2",92,0) S SCASDT=+$P(SCPTX,U,4) "RTN","SCMCMU2",93,0) S SCUNDT=+$P(SCPTX,U,5) "RTN","SCMCMU2",94,0) ; "RTN","SCMCMU2",95,0) ; -- unassign from positions first "RTN","SCMCMU2",96,0) S SCPOS=0 "RTN","SCMCMU2",97,0) F S SCPOS=$O(@SCPTTP@(DFN,SCPOS)) Q:'SCPOS D Q:'SCOK "RTN","SCMCMU2",98,0) . S SCOK=$$TPDIS(SCDATE,SCPOS,SCNT,$G(@SCPTTP@(DFN,SCPOS))) "RTN","SCMCMU2",99,0) ; "RTN","SCMCMU2",100,0) IF 'SCOK D "RTN","SCMCMU2",101,0) . S @SCERRAR@(SCNT,"TEAM",SCTEAM,1)="Team still assigned to patient." "RTN","SCMCMU2",102,0) . S @SCERRAR@(SCNT,"TEAM",SCTEAM,2)="Not able to unassign at least one position." "RTN","SCMCMU2",103,0) ; "RTN","SCMCMU2",104,0) IF SCOK D "RTN","SCMCMU2",105,0) . ; -- if assignment date is in future then delete "RTN","SCMCMU2",106,0) . IF SCASDT>DT,SCASDT>SCDATE D Q "RTN","SCMCMU2",107,0) . . N DA,DIK "RTN","SCMCMU2",108,0) . . S DA=SCIEN,DIK="^SCPT(404.42," "RTN","SCMCMU2",109,0) . . D LOCK(SCNODE) "RTN","SCMCMU2",110,0) . . D ^DIK "RTN","SCMCMU2",111,0) . . D UNLOCK(SCNODE) "RTN","SCMCMU2",112,0) . . S @SCOKAR@(SCNT,"TEAM",SCTEAM,1)=">>> Future team assignment deleted." "RTN","SCMCMU2",113,0) . . S @SCOKAR@(SCNT,"TEAM",SCTEAM,2)=" Assignment Date: "_$$FMTE^XLFDT(SCASDT,"5Z")_" Entry#: "_SCIEN "RTN","SCMCMU2",114,0) . . Q "RTN","SCMCMU2",115,0) . ; "RTN","SCMCMU2",116,0) . ; -- if assignment date is after effective date but before today "RTN","SCMCMU2",117,0) . IF SCASDT>SCDATE,SCASDT
SCDATE,SCUNDT
SCDATE D "RTN","SCMCMU2",143,0) . . S @SCOKAR@(SCNT,"TEAM",SCTEAM,1)=">>> Future team unassignment date was changed." "RTN","SCMCMU2",144,0) . . S @SCOKAR@(SCNT,"TEAM",SCTEAM,2)=" Old Date: "_$$FMTE^XLFDT(SCUNDT,"5Z")_" New Date: "_$$FMTE^XLFDT(SCDATE,"5Z")_" Entry#: "_SCIEN_")" "RTN","SCMCMU2",145,0) ; "RTN","SCMCMU2",146,0) Q SCOK "RTN","SCMCMU2",147,0) ; "RTN","SCMCMU2",148,0) TPDIS(SCDATE,SCPOS,SCNT,SCPTX) ; -- position unassignment for patient "RTN","SCMCMU2",149,0) ; input: SCDATE := effective date "RTN","SCMCMU2",150,0) ; SCTEAM := ien of TEAM POSITION entry (404.57) "RTN","SCMCMU2",151,0) ; SCNT := entry in @SCPTINFO@ & @SCPTALL@ arrays "RTN","SCMCMU2",152,0) ; SCPTX := format defined by output of $$PTTP^SCAPMC2 "RTN","SCMCMU2",153,0) ; "RTN","SCMCMU2",154,0) N SCNODE,SCOK,SCERRS,DFN,SCIEN,SCASDT,SCUNDT "RTN","SCMCMU2",155,0) S SCASDT=+$P(SCPTX,U,4) "RTN","SCMCMU2",156,0) S SCUNDT=+$P(SCPTX,U,5) "RTN","SCMCMU2",157,0) ; "RTN","SCMCMU2",158,0) S SCOK=1 "RTN","SCMCMU2",159,0) S SCERRS="SCERRLST" "RTN","SCMCMU2",160,0) ; "RTN","SCMCMU2",161,0) S DFN=+SCPTX "RTN","SCMCMU2",162,0) S SCIEN=+$P(SCPTX,U,3) "RTN","SCMCMU2",163,0) S SCNODE=$NA(^SCPT(404.43,SCIEN,0)) "RTN","SCMCMU2",164,0) S SCASDT=+$P(SCPTX,U,4) "RTN","SCMCMU2",165,0) S SCUNDT=+$P(SCPTX,U,5) "RTN","SCMCMU2",166,0) ; "RTN","SCMCMU2",167,0) ; if assignment date is in future then delete "RTN","SCMCMU2",168,0) IF SCOK D "RTN","SCMCMU2",169,0) . ; -- if assignment date is in future then delete "RTN","SCMCMU2",170,0) . IF SCASDT>DT,SCASDT>SCDATE D Q "RTN","SCMCMU2",171,0) . . N DA,DIE,DIK,DR D LOCK(SCNODE) ; Call Lock subroutine prior to DIE Call SD*5.3*563 "RTN","SCMCMU2",172,0) . . S DA=SCIEN,DIE="^SCPT(404.43,",DR=".04///"_DT D ^DIE ; og/sd/524 "RTN","SCMCMU2",173,0) . . ;Set variables DIK and DA after DIE call to preserve value SD*5.3*563 "RTN","SCMCMU2",174,0) . . S DIK="^SCPT(404.43,",DA=SCIEN D ^DIK "RTN","SCMCMU2",175,0) . . D UNLOCK(SCNODE) "RTN","SCMCMU2",176,0) . . S @SCOKAR@(SCNT,"POS",SCPOS,1)=" >>> Future position assignment deleted." "RTN","SCMCMU2",177,0) . . S @SCOKAR@(SCNT,"POS",SCPOS,2)=" Assignment Date: "_$$FMTE^XLFDT(SCASDT,"5Z")_" Entry#: "_SCIEN "RTN","SCMCMU2",178,0) . . Q "RTN","SCMCMU2",179,0) . ; "RTN","SCMCMU2",180,0) . ; -- if assignment date is after effective date but before today "RTN","SCMCMU2",181,0) . IF SCASDT>SCDATE,SCASDT
SCDATE,SCUNDT
SCDATE D "RTN","SCMCMU2",207,0) . . S @SCOKAR@(SCNT,"POS",SCPOS,1)=" >>> Future position unassignment date was changed." "RTN","SCMCMU2",208,0) . . S @SCOKAR@(SCNT,"POS",SCPOS,2)=" Old Date: "_$$FMTE^XLFDT(SCUNDT,"5Z")_" New Date: "_$$FMTE^XLFDT(SCDATE,"5Z")_" Entry#: "_SCIEN_")" "RTN","SCMCMU2",209,0) . . Q "RTN","SCMCMU2",210,0) ; "RTN","SCMCMU2",211,0) IF SCOK D "RTN","SCMCMU2",212,0) . S @SCOKAR@(SCNT,"CLINIC",SCPOS,1)=$$CLDIS(SCPOS) "RTN","SCMCMU2",213,0) . Q "RTN","SCMCMU2",214,0) ; "RTN","SCMCMU2",215,0) TPDISQ Q SCOK "RTN","SCMCMU2",216,0) ; "RTN","SCMCMU2",217,0) CLDIS(SCPOS) ; -- discharge from clinic "RTN","SCMCMU2",218,0) N SCPOS0,SCCLN,SCREA,SCRET "RTN","SCMCMU2",219,0) S SCRET="" "RTN","SCMCMU2",220,0) ; "RTN","SCMCMU2",221,0) ; -- if user did not request clinic discharge, quit "RTN","SCMCMU2",222,0) IF '$G(SCTPDIS(+SCPOS)) G CLDISQ "RTN","SCMCMU2",223,0) ; "RTN","SCMCMU2",224,0) S SCPOS0=$G(^SCTM(404.57,SCPOS,0)) "RTN","SCMCMU2",225,0) S SCCLN=$P(SCPOS0,U,9) "RTN","SCMCMU2",226,0) IF SCCLN D "RTN","SCMCMU2",227,0) . S SCREA="Team position mass discharge" "RTN","SCMCMU2",228,0) . S SCRET=$$EN^SCMCMU3(DFN,SCCLN,SCDATE,SCREA) "RTN","SCMCMU2",229,0) . Q "RTN","SCMCMU2",230,0) ELSE D "RTN","SCMCMU2",231,0) . S SCRET="0^No clinic assignment to position" "RTN","SCMCMU2",232,0) . Q "RTN","SCMCMU2",233,0) ; "RTN","SCMCMU2",234,0) CLDISQ Q SCRET "RTN","SCMCMU2",235,0) ; "RTN","SCMCMU2",236,0) LOCK(NODE) ; -- lock node "RTN","SCMCMU2",237,0) F L +@NODE:5 IF $T Q "RTN","SCMCMU2",238,0) Q "RTN","SCMCMU2",239,0) ; "RTN","SCMCMU2",240,0) UNLOCK(NODE) ; -- unlock node "RTN","SCMCMU2",241,0) L -@NODE "RTN","SCMCMU2",242,0) Q "RTN","SCMCMU2",243,0) ; "RTN","SCMCQK") 0^2^B21155109^B16433135 "RTN","SCMCQK",1,0) SCMCQK ;ALB/REW - Single Pt Tm/Pt Tm Pos Assign and Discharge ; 5/17/12 1:39pm "RTN","SCMCQK",2,0) ;;5.3;Scheduling;**148,177,297,563**;AUG 13, 1993;Build 45 "RTN","SCMCQK",3,0) ; "RTN","SCMCQK",4,0) ; "RTN","SCMCQK",5,0) ; Reference/ICR "RTN","SCMCQK",6,0) ; ^DPT(DFN,.35)/10035 "RTN","SCMCQK",7,0) ; "RTN","SCMCQK",8,0) ; "RTN","SCMCQK",9,0) EN ; - main call "RTN","SCMCQK",10,0) W !,"Primary Care Team/PC Assignment/Unassignment",! "RTN","SCMCQK",11,0) W !,?6,"Prior to using this option, PCMM's Graphical User Interface (GUI)" "RTN","SCMCQK",12,0) W !,?6,"must be used to:" "RTN","SCMCQK",13,0) W !,?10,"1) Setup active primary care and non-primary care team(s)" "RTN","SCMCQK",14,0) W !,?10,"2) Setup active PC and non-primary care Practitioner position(s)" "RTN","SCMCQK",15,0) W !,?10,"3) Setup any necessary preceptor/preceptee relationships" "RTN","SCMCQK",16,0) W !,?10,"4) Assign practitioner to position(s)" "RTN","SCMCQK",17,0) W !!?6,"A patient can only have one PC team and one" "RTN","SCMCQK",18,0) W !?6,"PC Position assignment on a given day. The patient must be" "RTN","SCMCQK",19,0) W !?6,"assigned to a position's team to be assigned to the position." "RTN","SCMCQK",20,0) W !!?6,"Note: You must use the PCMM GUI if the patient was:" "RTN","SCMCQK",21,0) W !?10,"o unassigned from PC assignment today or in the future" "RTN","SCMCQK",22,0) W !?10,"o assigned to a future PC assignment." "RTN","SCMCQK",23,0) N DFN "RTN","SCMCQK",24,0) F S DFN=$$PATIENT() Q:DFN<0 D PAT "RTN","SCMCQK",25,0) Q "RTN","SCMCQK",26,0) ; "RTN","SCMCQK",27,0) PAT ;process patient "RTN","SCMCQK",28,0) Q:'$G(DFN) "RTN","SCMCQK",29,0) N SCTPSTAT,SCTMSTAT,SCSTAT,SCTM,SCTP,SDDOD,SDDODRES,SDUSRANS "RTN","SCMCQK",30,0) ;If patient is deceased prompt user to continue SD*5.3*563 "RTN","SCMCQK",31,0) I $P($G(^DPT(DFN,.35)),U)'="" D I SDUSRANS'="Y" Q "RTN","SCMCQK",32,0) .S SDDOD=$P(^DPT(DFN,.35),U) "RTN","SCMCQK",33,0) .S SDDODRES=$$FMTE^XLFDT(SDDOD) "RTN","SCMCQK",34,0) .W !!,"This Patient is deceased as of "_SDDODRES_". Would you like to continue?" "RTN","SCMCQK",35,0) .S DIR(0)="SA^Y:YES;N:NO" "RTN","SCMCQK",36,0) .S DIR("B")="NO" "RTN","SCMCQK",37,0) .S DIR("?")="[Y]ES=continue with current patient, [N]o=select a new patient or quit" "RTN","SCMCQK",38,0) .W ! D ^DIR K DIR S SDUSRANS=Y "RTN","SCMCQK",39,0) .I $D(DIRUT) K DIRUT,DUOUT,DTOUT,X,Y Q "RTN","SCMCQK",40,0) ;End SD*5.3*563 "RTN","SCMCQK",41,0) W !,"Checking PC Team and Position Status...",! "RTN","SCMCQK",42,0) ;display PC info, check if patient has a current PC team "RTN","SCMCQK",43,0) D PCMM^SCRPU4(DFN,DT) "RTN","SCMCQK",44,0) D DSPL^SCMCQK2 "RTN","SCMCQK",45,0) N DATA "RTN","SCMCQK",46,0) S DATA=$$IU^SCMCTSK1(DFN) "RTN","SCMCQK",47,0) I $E(DATA)=1 I $D(^XUSEC("SC PCMM SETUP",+$G(DUZ))) D "RTN","SCMCQK",48,0) .W !,"This patient was inactivated from "_$P(DATA,"~",2)_" TEAM" "RTN","SCMCQK",49,0) .W !,$P(DATA,"~",4)_" Position" "RTN","SCMCQK",50,0) .W !,"Do you wish to reactivate" S %=2 D YN^DICN "RTN","SCMCQK",51,0) .I %=1 D FILEIN^SCMCTSK3(.DATA,+$P(DATA,"~",6)) "RTN","SCMCQK",52,0) W !,"Do you want to make a primary care assignment/unassignment" S %=1 D YN^DICN Q:%<0 "RTN","SCMCQK",53,0) I %=2 G NPC^SCMCQK2 "RTN","SCMCQK",54,0) ;below functions return status^message^pointer "RTN","SCMCQK",55,0) S SCTMSTAT=$$YSPTTMPC^SCMCTMU2(DFN,DT) ;ok to assign new PC team? "RTN","SCMCQK",56,0) S SCTPSTAT=$$YSPTTPPC^SCMCTPU2(DFN,DT,1) ;ok to assign new PC prac? "RTN","SCMCQK",57,0) ;what is current/future PC assignment status? "RTN","SCMCQK",58,0) S SCSTAT=$S((SCTMSTAT&SCTPSTAT):"NONE",('SCTMSTAT&SCTPSTAT):"TEAM",('SCTMSTAT&'SCTPSTAT):"BOTH",1:"ERROR") ;error if PC pract w/o PC team assignment "RTN","SCMCQK",59,0) W:SCSTAT="NONE" !,"No current PC Team/PC Practitioner Assignments" "RTN","SCMCQK",60,0) IF $S(SCTMSTAT:0,(SCTMSTAT["future"):1,1:0) W !,$P(SCTMSTAT,U,2) S SCSTAT="FUTURE" "RTN","SCMCQK",61,0) IF $S(SCTPSTAT:0,(SCTPSTAT["future"):1,1:0) W !,$P(SCTPSTAT,U,2) S SCSTAT="FUTURE" "RTN","SCMCQK",62,0) S SCTM=$P(SCTMSTAT,U,3) "RTN","SCMCQK",63,0) S SCTP=$P(SCTPSTAT,U,3) "RTN","SCMCQK",64,0) D @SCSTAT "RTN","SCMCQK",65,0) D BREAK "RTN","SCMCQK",66,0) Q "RTN","SCMCQK",67,0) ; "RTN","SCMCQK",68,0) BREAK ; "RTN","SCMCQK",69,0) N DIR,X,Y "RTN","SCMCQK",70,0) S DIR(0)="EA",DIR("A",1)="",DIR("A")="Press enter to continue." "RTN","SCMCQK",71,0) D ^DIR "RTN","SCMCQK",72,0) Q "RTN","SCMCQK",73,0) ; "RTN","SCMCQK",74,0) NONE ; "RTN","SCMCQK",75,0) N SCASSDT "RTN","SCMCQK",76,0) D ASTM^SCMCQK1 "RTN","SCMCQK",77,0) Q "RTN","SCMCQK",78,0) TEAM ; "RTN","SCMCQK",79,0) N DIR,X,Y,SCDISCH,SCASSDT,SCSELECT "RTN","SCMCQK",80,0) S DIR(0)="SO^1:POSITION ASSIGNMENT - BY PRACTITIONER NAME;2:POSITION ASSIGNMENT - BY POSITION NAME;3:TEAM UNASSIGNMENT" "RTN","SCMCQK",81,0) D ^DIR "RTN","SCMCQK",82,0) IF $P(Y,U,1)=1!($P(Y,U,1)=2) D "RTN","SCMCQK",83,0) .S SCSELECT=$S($P(Y,U,1)=1:"PRACT",1:"POSIT") "RTN","SCMCQK",84,0) .D ASTP^SCMCQK1 "RTN","SCMCQK",85,0) ELSE D:$P(Y,U,1)=3 UNTM^SCMCQK1 "RTN","SCMCQK",86,0) Q "RTN","SCMCQK",87,0) ; "RTN","SCMCQK",88,0) BOTH ; "RTN","SCMCQK",89,0) N DIR,X,Y,SCDISCH "RTN","SCMCQK",90,0) S DIR(0)="SO^1:PC ASSIGNMENT UNASSIGNMENT;2:TEAM UNASSIGNMENT" "RTN","SCMCQK",91,0) D ^DIR "RTN","SCMCQK",92,0) IF $P(Y,U,1)=1 D "RTN","SCMCQK",93,0) .D UNTP^SCMCQK1 "RTN","SCMCQK",94,0) ELSE D:$P(Y,U,1)=2 UNTM^SCMCQK1 "RTN","SCMCQK",95,0) Q "RTN","SCMCQK",96,0) ; "RTN","SCMCQK",97,0) FUTURE ; "RTN","SCMCQK",98,0) W !,"This patient has future assignments for Primary Care" "RTN","SCMCQK",99,0) W !,"Team and/or Practitioner" "RTN","SCMCQK",100,0) W !!!,"You must use PCMM's Graphical User Interface to change" "RTN","SCMCQK",101,0) Q "RTN","SCMCQK",102,0) ; "RTN","SCMCQK",103,0) ERROR ; "RTN","SCMCQK",104,0) W !,"This patient has NO active Primary Care Team, but does have" "RTN","SCMCQK",105,0) W !,"an active PC Position Assignment" "RTN","SCMCQK",106,0) W !!!,"You must use PCMM's Graphical User Interface to correct" "RTN","SCMCQK",107,0) Q "RTN","SCMCQK",108,0) ; "RTN","SCMCQK",109,0) PATIENT() ;Return Patient DFN or -1 "RTN","SCMCQK",110,0) ; "RTN","SCMCQK",111,0) N DIC,X,Y "RTN","SCMCQK",112,0) W !!! "RTN","SCMCQK",113,0) S DIC=2 "RTN","SCMCQK",114,0) S DIC(0)="AEMQZ" "RTN","SCMCQK",115,0) D ^DIC "RTN","SCMCQK",116,0) Q $S($D(DTOUT):-1,$D(DUOUT):-1,(Y<0):-1,1:+Y) "RTN","SCMCQK1") 0^4^B106090791^B92256420 "RTN","SCMCQK1",1,0) SCMCQK1 ;ALBOI/REW - Single Pt Tm/Pt Tm Pos Assign and Discharge;11/07/02 ; 6/13/12 3:38pm "RTN","SCMCQK1",2,0) ;;5.3;Scheduling;**148,177,231,264,436,297,446,524,535,563**;AUG 13, 1993;Build 45 "RTN","SCMCQK1",3,0) ; "RTN","SCMCQK1",4,0) ; "RTN","SCMCQK1",5,0) ; Reference/ICR "RTN","SCMCQK1",6,0) ; ^DPT(DFN,.35)/10035 "RTN","SCMCQK1",7,0) ; "RTN","SCMCQK1",8,0) ; "RTN","SCMCQK1",9,0) ;04/25/2006 SD*5.3*446 INTER-FACILITY TRANSFER "RTN","SCMCQK1",10,0) UNTP ;unassign patient from pc prac position "RTN","SCMCQK1",11,0) I '$G(SCTP) W !,"No position defined" Q "RTN","SCMCQK1",12,0) N OK,SCER,SCCL,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS "RTN","SCMCQK1",13,0) S OK=0 "RTN","SCMCQK1",14,0) W !,"About to Unassign "_$$NAME(DFN)_" from: ",!,?8,$$POSITION(SCTP)_" position ["_$P($$GETPRTP^SCAPMCU2(SCTP,DT),U,2)_"]" "RTN","SCMCQK1",15,0) S SCDISCH=$$DATE("D",DFN) ;SD*5.3*563 pass DFN "RTN","SCMCQK1",16,0) G:SCDISCH<1 QTUNTP "RTN","SCMCQK1",17,0) G:'$$CONFIRM() QTUNTP "RTN","SCMCQK1",18,0) S OK=$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER) ; og/sd/524 "RTN","SCMCQK1",19,0) G:OK'>0 QTUNTP "RTN","SCMCQK1",20,0) ;comment out following lines in SD*5.3*535 - clinic enrollment no longer used "RTN","SCMCQK1",21,0) ;S SCCL=$P($G(^SCTM(404.57,+$G(SCTP),0)),U,9) "RTN","SCMCQK1",22,0) ;I SCCL D DISCL "RTN","SCMCQK1",23,0) QTUNTP W !,"Position Unassignment "_$S(OK:"made.",1:"NOT made.") "RTN","SCMCQK1",24,0) Q "RTN","SCMCQK1",25,0) ENRCL ; no longer used with SD*5.3*535 "RTN","SCMCQK1",26,0) Q "RTN","SCMCQK1",27,0) N SCRESTA,SCREST,SCCLNM,SCTM "RTN","SCMCQK1",28,0) N SCCL "RTN","SCMCQK1",29,0) F SCCL=0:0 S SCCL=$O(^SCTM(404.57,+$G(SCTP),5,SCCL)) Q:'SCCL D "RTN","SCMCQK1",30,0) .Q:$$ACTCL(DFN,SCCL) "RTN","SCMCQK1",31,0) .W !!!,"The "_$$POSITION(SCTP)_" is associated with the ",$$CLINIC(SCCL)_" clinic." "RTN","SCMCQK1",32,0) .;SCRESTA = Array of pt's teams causing restricted consults "RTN","SCMCQK1",33,0) .N SCRESTA "RTN","SCMCQK1",34,0) .S SCREST=$$RESTPT^SCAPMCU4(DFN,DT,"SCRESTA") "RTN","SCMCQK1",35,0) .I SCREST D "RTN","SCMCQK1",36,0) ..N SCTM "RTN","SCMCQK1",37,0) ..S SCCLNM=Y "RTN","SCMCQK1",38,0) ..W !,?5,"Patient has restricted consults due to team assignment(s):" "RTN","SCMCQK1",39,0) ..S SCTM=0 "RTN","SCMCQK1",40,0) ..F S SCTM=$O(SCRESTA(SCTM)) Q:'SCTM W !,?10,SCRESTA(SCTM) "RTN","SCMCQK1",41,0) .I SCREST&'$G(SCOKCONS) D G QTECL "RTN","SCMCQK1",42,0) ..W !,?5,"This patient may only be enrolled in clinics via" "RTN","SCMCQK1",43,0) ..W !,?15,"Edit Clinic Enrollment Data option" "RTN","SCMCQK1",44,0) .W !,"Do you wish to enroll the patient from this clinic on " "RTN","SCMCQK1",45,0) .S Y=SCASSDT X ^DD("DD") W Y,"?" "RTN","SCMCQK1",46,0) .I $$YESNO() D "RTN","SCMCQK1",47,0) ..W !,"Clinic Enrollment" "RTN","SCMCQK1",48,0) ..I $$ACPTCL^SCAPMC18(DFN,SCCL,,SCASSDT,"SCENER") W " made" "RTN","SCMCQK1",49,0) ..E W "NOT made " "RTN","SCMCQK1",50,0) QTECL Q "RTN","SCMCQK1",51,0) DISCL ; no longer used with SD*5.3*535 "RTN","SCMCQK1",52,0) Q "RTN","SCMCQK1",53,0) N SCCL F SCCL=0:0 S SCCL=$O(^SCTM(404.57,+$G(SCTP),5,SCCL)) Q:'SCCL D "RTN","SCMCQK1",54,0) .Q:'$$ACTCL(DFN,SCCL) "RTN","SCMCQK1",55,0) .W !,$$NAME(DFN)," is enrolled in the associated "_$$CLINIC(SCCL)_" clinic." "RTN","SCMCQK1",56,0) .W !,"Do you wish to discharge the patient from this clinic on " "RTN","SCMCQK1",57,0) .S Y=SCDISCH X ^DD("DD") W Y,"?" "RTN","SCMCQK1",58,0) .Q:'$$YESNO() "RTN","SCMCQK1",59,0) .N SDFN,SDCLN S SDFN=DFN,SDCLN=SCCL "RTN","SCMCQK1",60,0) .N DFN D ^SDCD "RTN","SCMCQK1",61,0) QTDCL Q "RTN","SCMCQK1",62,0) UNTM ; "RTN","SCMCQK1",63,0) ;assign patient from pc team (and pc position if possible) "RTN","SCMCQK1",64,0) N OK,SCER,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS,OK2,OK3 "RTN","SCMCQK1",65,0) S OK=0 "RTN","SCMCQK1",66,0) W !!,"About to Unassign "_$$NAME(DFN)_" from "_$$TEAMNM(SCTM)_" team" "RTN","SCMCQK1",67,0) W:'SCTPSTAT !,?5,"AND from "_$$POSITION(SCTP)_" position ["_$$WRITETP^SCMCDD1(SCTP)_"]" "RTN","SCMCQK1",68,0) S SCDISCH=$$DATE("D",DFN) ;SD*5.3*563 pass DFN "RTN","SCMCQK1",69,0) G:SCDISCH<1 QTUNTM "RTN","SCMCQK1",70,0) G:'$$CONFIRM() QTUNTM "RTN","SCMCQK1",71,0) IF 'SCTPSTAT D G:OK2'>0 QTUNTM "RTN","SCMCQK1",72,0) .W !,"PC assignment unassigned." "RTN","SCMCQK1",73,0) .S OK2=$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER) "RTN","SCMCQK1",74,0) .IF OK2>0 D "RTN","SCMCQK1",75,0) ..W "made." "RTN","SCMCQK1",76,0) ..S SCCL=$P(^SCTM(404.57,SCTP,0),U,9) "RTN","SCMCQK1",77,0) ..;D:SCCL DISCL ;commented out in SD*5.3*535 "RTN","SCMCQK1",78,0) S OK3=$$ALLPOS() "RTN","SCMCQK1",79,0) IF $$OKINPTTM^SCMCTMU2(DFN,SCTM,SCDISCH) D "RTN","SCMCQK1",80,0) .S OK=$$INPTSCTM^SCAPMC7(DFN,SCTM,SCDISCH,.SCER) "RTN","SCMCQK1",81,0) ELSE D "RTN","SCMCQK1",82,0) .W !,"Future/Current Patient-Position Assignment exists" "RTN","SCMCQK1",83,0) QTUNTM W !,"Team Unassignment "_$S(OK:"made",1:"NOT made.") "RTN","SCMCQK1",84,0) Q "RTN","SCMCQK1",85,0) ALLPOS() ;unassign all patient-positions for team "RTN","SCMCQK1",86,0) ;not stand-alone - needs dfn,sctm "RTN","SCMCQK1",87,0) ;return 1=No positions left assigned|0=At least 1 position assigned "RTN","SCMCQK1",88,0) N OK,SCDT1,SCPTTPX,SCERRR,SCTP,SCCNT,SCPTTPI,SCLOC,SCNODE,SCPTTP2 "RTN","SCMCQK1",89,0) S SCDT1("BEGIN")=SCDISCH+1 "RTN","SCMCQK1",90,0) S SCDT1("END")=3990101 "RTN","SCMCQK1",91,0) S SCDT1("INCL")=0 ;anytime from now to future "RTN","SCMCQK1",92,0) S OK=$$TPPT^SCAPMC23(DFN,"SCDT1",,,,,,"SCPTTPX",.SCERRR) "RTN","SCMCQK1",93,0) S (SCTP,SCCNT)=0 "RTN","SCMCQK1",94,0) W !,"Checking for other position assignments to team..." "RTN","SCMCQK1",95,0) F S SCTP=$O(SCPTTPX("SCTP",SCTM,SCTP)) Q:'SCTP S SCCNT=SCCNT+1 D "RTN","SCMCQK1",96,0) .S SCPTTPI=$O(SCPTTPX("SCTP",SCTM,SCTP,9999999),-1) "RTN","SCMCQK1",97,0) .S SCLOC=$O(SCPTTPX("SCTP",SCTM,SCTP,SCPTTPI,0)) "RTN","SCMCQK1",98,0) .S SCNODE=SCPTTPX(SCLOC) "RTN","SCMCQK1",99,0) .S SCPTTP2(SCTP)="" "RTN","SCMCQK1",100,0) .W !,?3,$P(SCNODE,U,2)," ",$P(SCNODE,U,8) "RTN","SCMCQK1",101,0) .IF $P(SCNODE,U,6)!(SCDISCH'>$P(SCNODE,U,5)) D "RTN","SCMCQK1",102,0) ..W !,?5,"Unassignment date already exists or unassignment after assignment date" "RTN","SCMCQK1",103,0) ..W !,?15,"- Correct via PCMM GUI" "RTN","SCMCQK1",104,0) ..S OK=0 "RTN","SCMCQK1",105,0) W !,?5,$S(SCCNT:SCCNT,1:"No")_" current/future position assignment(s)" "RTN","SCMCQK1",106,0) G:'OK!('SCCNT) QTALL "RTN","SCMCQK1",107,0) W !!,"About to unassign the above patient-position assignments" "RTN","SCMCQK1",108,0) IF '$$CONFIRM S OK=0 G QTALL "RTN","SCMCQK1",109,0) S SCTP=0 "RTN","SCMCQK1",110,0) F S SCTP=$O(SCPTTP2(SCTP)) Q:'SCTP D Q:'OK "RTN","SCMCQK1",111,0) .S OK=$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER) "RTN","SCMCQK1",112,0) .W:'OK !,?10,"Problem with unassignment, correct via PCMM GUI" "RTN","SCMCQK1",113,0) QTALL Q OK "RTN","SCMCQK1",114,0) ASTM ;assign patient to PC team "RTN","SCMCQK1",115,0) N DIC,Y,OK,SCTM,SCTMFLDS,SCER,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS "RTN","SCMCQK1",116,0) S OK=0 "RTN","SCMCQK1",117,0) W !!,"About to Assign "_$$NAME(DFN)_" to a primary care team" "RTN","SCMCQK1",118,0) I $$SC(DFN) W !!,"********** This patient is 50 percent or greater service-connected ************" "RTN","SCMCQK1",119,0) S DIC="^SCTM(404.51," "RTN","SCMCQK1",120,0) S DIC(0)="AEMQZ" "RTN","SCMCQK1",121,0) S DIC("S")="IF $$ACTTM^SCMCTMU(Y,DT)&($P($G(^SCTM(404.51,Y,0)),U,5))" "RTN","SCMCQK1",122,0) ;select from active teams that can be PC Teams "RTN","SCMCQK1",123,0) D ^DIC "RTN","SCMCQK1",124,0) G:Y<1 QTASTM "RTN","SCMCQK1",125,0) S SCTM=+Y "RTN","SCMCQK1",126,0) ;The following logic to present warning message added per SD*5.3*436 "RTN","SCMCQK1",127,0) I $P($G(^SCTM(404.51,SCTM,0)),U,10) D G:'SCFLAG QTASTM "RTN","SCMCQK1",128,0) .S SCFLAG=0 "RTN","SCMCQK1",129,0) .W !!,"This team is closed to further patient assignments. While you are" "RTN","SCMCQK1",130,0) .W !,"not currently prevented from assigning this patient, you may want to" "RTN","SCMCQK1",131,0) .W !,"check before continuing." "RTN","SCMCQK1",132,0) .Q:'$$YESNO1() ; new function call per SD*5.3*436 "RTN","SCMCQK1",133,0) .Q:'$$CONFIRM() "RTN","SCMCQK1",134,0) .S SCFLAG=1 W ! "RTN","SCMCQK1",135,0) S SCASSDT=$$DATE("A",DFN) ;SD*5.3*563 Pass DFN "RTN","SCMCQK1",136,0) G:SCASSDT<1 QTASTM "RTN","SCMCQK1",137,0) S SCTMCT=$$TEAMCNT^SCAPMCU1(SCTM) "RTN","SCMCQK1",138,0) S SCTMMAX=$P($$GETEAM^SCAPMCU3(SCTM),"^",8) "RTN","SCMCQK1",139,0) I SCTMCT'0 "RTN","SCMCQK1",214,0) YESNO1() ; added per SD*5.3*436 "RTN","SCMCQK1",215,0) N DIR,X,Y "RTN","SCMCQK1",216,0) S DIR(0)="Y",DIR("A")="Do you wish to assign this patient now (Yes/No)?" "RTN","SCMCQK1",217,0) S DIR("B")="NO" "RTN","SCMCQK1",218,0) D ^DIR "RTN","SCMCQK1",219,0) Q Y>0 "RTN","SCMCQK1",220,0) YESNO2() ; "RTN","SCMCQK1",221,0) N DIR,X,Y "RTN","SCMCQK1",222,0) S DIR(0)="Y",DIR("B")="NO" "RTN","SCMCQK1",223,0) S DIR("A")="Do you wish to continue with the assignment (Yes/No)?" "RTN","SCMCQK1",224,0) D ^DIR "RTN","SCMCQK1",225,0) Q Y>0 "RTN","SCMCQK1",226,0) CONFIRM() ;confirmation call "RTN","SCMCQK1",227,0) N DIR,X,Y "RTN","SCMCQK1",228,0) S DIR("A")="Are you sure (Yes/No)" "RTN","SCMCQK1",229,0) S DIR(0)="Y" "RTN","SCMCQK1",230,0) D ^DIR "RTN","SCMCQK1",231,0) Q +Y=1 "RTN","SCMCQK1",232,0) SELPOS() ;return way to select position: 1=PRACT,2=POSIT,3=NONE "RTN","SCMCQK1",233,0) N DIR,X,Y "RTN","SCMCQK1",234,0) W !,"Choose way to select PC POSITION Assignment: " "RTN","SCMCQK1",235,0) S DIR(0)="SO^0:NONE;1:BY PRACTITIONER ASSIGNMENT;2:BY POSITION ASSIGNMENT" "RTN","SCMCQK1",236,0) S DIR("B")=1 "RTN","SCMCQK1",237,0) D ^DIR "RTN","SCMCQK1",238,0) Q $S(Y'>0:"",+Y=1:"PRACT",1:"POSIT") "RTN","SCMCQK1",239,0) DATE(TYPE,DFN) ;type=A(Assignment) or D(Unassignment) "RTN","SCMCQK1",240,0) ; Returns assignment/unassignment date or "^" "RTN","SCMCQK1",241,0) I '$G(DFN) Q -1 "RTN","SCMCQK1",242,0) N DIR,X,Y,SDFLG,SDY "RTN","SCMCQK1",243,0) ;SD*5.3*563 SDFLG=0 allow to proceed with date if prior to DOD "RTN","SCMCQK1",244,0) F D Q:SDFLG=0 "RTN","SCMCQK1",245,0) .S DIR("A")=$S(TYPE="A":"Assignment",1:"Unassignment")_" date: " "RTN","SCMCQK1",246,0) .S DIR(0)="DA^::EXP" "RTN","SCMCQK1",247,0) .S Y=$S($D(SCDISCH):SCDISCH,$D(SCASSDT):SCASSDT,(TYPE="A"):"TODAY",1:"TODAY-1") "RTN","SCMCQK1",248,0) .X ^DD("DD") "RTN","SCMCQK1",249,0) .S DIR("B")=Y "RTN","SCMCQK1",250,0) .D ^DIR K DIR S SDY=Y "RTN","SCMCQK1",251,0) .I $D(DIRUT) K DIRUT,DUOUT,X,Y S SDFLG=0 Q "RTN","SCMCQK1",252,0) .D WARNMESS^SCMCQK1(SDY,DFN,.SDFLG) "RTN","SCMCQK1",253,0) Q SDY "RTN","SCMCQK1",254,0) ACTCL(DFN,SCCL) ;is patient enrolled in clinic? - not called with SD*5.3*535 "RTN","SCMCQK1",255,0) Q "RTN","SCMCQK1",256,0) N SCXX "RTN","SCMCQK1",257,0) S SCXX=$O(^DPT(DFN,"DE","B",SCCL,9999),-1) "RTN","SCMCQK1",258,0) Q $S('SCXX:0,($P(^DPT(DFN,"DE",+SCXX,0),U,2)="I"):0,1:1) "RTN","SCMCQK1",259,0) PRACSCR(SC40452) ;screen for for file 404.52 "RTN","SCMCQK1",260,0) N SCP,SCNODE,OK "RTN","SCMCQK1",261,0) S SCP=$G(^SCTM(404.52,SC40452,0)) "RTN","SCMCQK1",262,0) S OK=0 "RTN","SCMCQK1",263,0) G:'SCP QTPP "RTN","SCMCQK1",264,0) S SCNODE=$G(^SCTM(404.57,+SCP,0)) "RTN","SCMCQK1",265,0) S OK=$S($P(SCNODE,U,2)'=SCTM:0,'$P(SCNODE,U,4):0,($O(^SCTM(404.52,"AIDT",+SCP,1,""))'=-$P(SCP,U,2)):0,($O(^SCTM(404.52,"AIDT",+SCP,0,-$P(SCP,U,2)),-1)):0,($$ACTTP^SCMCTPU(+SCP)>0):1,1:0) "RTN","SCMCQK1",266,0) QTPP Q OK "RTN","SCMCQK1",267,0) POSSCR(SCTP) ;screen for file 404.57 "RTN","SCMCQK1",268,0) N SCNODE "RTN","SCMCQK1",269,0) S SCNODE=$G(^SCTM(404.57,SCTP,0)) "RTN","SCMCQK1",270,0) Q $S($P(SCNODE,U,2)'=SCTM:0,'$P(SCNODE,U,4):0,($$ACTTP^SCMCTPU(SCTP)>0):1,1:0) "RTN","SCMCQK1",271,0) Q "RTN","SCMCQK1",272,0) WAITYN() ; "RTN","SCMCQK1",273,0) N %,OK,Y "RTN","SCMCQK1",274,0) I SCTMCT1,1:1) Q 0 "RTN","SCMCQK1",276,0) N DIR,X,Y "RTN","SCMCQK1",277,0) S DIR(0)="Y",DIR("B")="NO" "RTN","SCMCQK1",278,0) S DIR("A")="Do you wish to place the patient on the wait list (Yes/No)?" "RTN","SCMCQK1",279,0) D ^DIR "RTN","SCMCQK1",280,0) I Y=1 S Y=$$WAITS^SCMCWAIT(DFN,SCTM,$G(SCTP),$G(SC)) I Y>0 W !,"Patient Placed on Wait List" "RTN","SCMCQK1",281,0) Q Y>0 "RTN","SCMCQK1",282,0) SC(DFN) ;Is patient 50 to 100% "RTN","SCMCQK1",283,0) D ELIG^VADPT Q $P($G(VAEL(3)),U,2)>49 "RTN","SCMCQK1",284,0) ; "RTN","SCMCQK1",285,0) WARNMESS(SDY,DFN,SDFLG) ;SD*5.3*563 "RTN","SCMCQK1",286,0) ;If the patient is deceased warns the user to choose assignment "RTN","SCMCQK1",287,0) ;date prior to the date of death "RTN","SCMCQK1",288,0) ;SDY - Assignment/Unassignment date "RTN","SCMCQK1",289,0) ;SDFLG=0 - Allow to proceed with the date if prior to DOD "RTN","SCMCQK1",290,0) ; "RTN","SCMCQK1",291,0) N SDDODPAT,SDDODCF "RTN","SCMCQK1",292,0) S SDFLG=1 "RTN","SCMCQK1",293,0) I $P($G(^DPT(DFN,.35)),U)="" S SDFLG=0 Q "RTN","SCMCQK1",294,0) I $P($G(^DPT(DFN,.35)),U)'="" D "RTN","SCMCQK1",295,0) .S SDDODPAT=$P($P(^DPT(DFN,.35),U),".") "RTN","SCMCQK1",296,0) .S SDDODCF=$$FMTE^XLFDT(SDDODPAT) "RTN","SCMCQK1",297,0) .I SDY=SDDODPAT D "RTN","SCMCQK1",299,0) ..W !,"Patient is deceased as of "_SDDODCF_". Please use an earlier Assignment date." "RTN","SCMCQK1",300,0) Q "RTN","SCMCQK2") 0^5^B59731461^B56192341 "RTN","SCMCQK2",1,0) SCMCQK2 ;ALB/REW - Single Pt Tm/Pt Tm Pos Assign and Discharge ; 5/16/12 12:09pm "RTN","SCMCQK2",2,0) ;;5.3;Scheduling;**297,563**;AUG 13, 1993;Build 45 "RTN","SCMCQK2",3,0) ; "RTN","SCMCQK2",4,0) DSPL ; "RTN","SCMCQK2",5,0) N LP,SCD,SCPOS "RTN","SCMCQK2",6,0) S SCTOK=$$TMPT^SCAPMC3(DFN,"SCDT","","SCD","SCER1") "RTN","SCMCQK2",7,0) S SCOK=$$TPPT^SCAPMC(DFN,"","","","","","","SCPOS","SCBKERR") "RTN","SCMCQK2",8,0) ; "RTN","SCMCQK2",9,0) ;loop through positions only getting the ones associated with the team "RTN","SCMCQK2",10,0) ;and that are active. "RTN","SCMCQK2",11,0) ; "RTN","SCMCQK2",12,0) F LP=0:0 S LP=$O(SCPOS(LP)) Q:'LP D "RTN","SCMCQK2",13,0) .I $P(SCPOS(LP),U,6)]"" K SCPOS(LP) Q "RTN","SCMCQK2",14,0) .S SCPOS("T",$P(SCPOS(LP),U,3),+SCPOS(LP))=SCPOS(LP) "RTN","SCMCQK2",15,0) S CNT=0,POS=0 "RTN","SCMCQK2",16,0) F LP=0:0 S LP=$O(SCD(LP)) Q:'LP S A=SCD(LP) I '$P(A,U,8) D "RTN","SCMCQK2",17,0) .I 'CNT W !!,"NON PC ASSIGNMENTS",! "RTN","SCMCQK2",18,0) .S CNT=CNT+1 W !,CNT,?4,"Non-PC Team: "_$P(A,U,2),?48,"Phone: "_$P($G(^SCTM(404.51,+A,0)),U,2) S DATA(CNT)=+A "RTN","SCMCQK2",19,0) .F I=0:0 S I=$O(SCPOS("T",+A,I)) Q:'I D "RTN","SCMCQK2",20,0) ..I $P(DATA(CNT),U,2) S CNT=CNT+1 "RTN","SCMCQK2",21,0) ..S B=SCPOS("T",+A,I) "RTN","SCMCQK2",22,0) ..S DATA(CNT)=(+A)_U_(+B),POS=1 "RTN","SCMCQK2",23,0) ..S SCPR=$$GETPRTP^SCAPMCU2(+B,DT),RES=$$NEWPERSN^SCMCGU(+SCPR,"SCPR") "RTN","SCMCQK2",24,0) ..W:$X>76 !,CNT,?4,"Non-PC Team: "_$P(A,U,2),?48,"Phone: "_$P($G(^SCTM(404.51,+A,0)),U,2) "RTN","SCMCQK2",25,0) ..W !,?7,"Provider: "_$P(SCPR,U,2),?45,"Position: "_$P(B,U,2)_" " "RTN","SCMCQK2",26,0) ..W !,?10,"Pager: "_$P($G(SCPR(+SCPR)),U,5),?48,"Phone: ",$P($G(SCPR(+SCPR)),U,2),?77," " "RTN","SCMCQK2",27,0) I 'CNT W !,"No active NON PC ASSIGNMENTS for this patient",! "RTN","SCMCQK2",28,0) Q "RTN","SCMCQK2",29,0) NPC N SCDT,SCER1,SCD,SCPOS "RTN","SCMCQK2",30,0) D DSPL "RTN","SCMCQK2",31,0) S DIR(0)="SO^0:NONE;1:TEAM ASSIGNMENT;"_$S(CNT:"2:POSITION ASSIGNMENT;3:UNASSIGNMENT;",1:"") "RTN","SCMCQK2",32,0) S DIR("B")=1 "RTN","SCMCQK2",33,0) D ^DIR "RTN","SCMCQK2",34,0) I Y=0 Q "RTN","SCMCQK2",35,0) I $D(DIRUT) K DIRUT,X,Y Q ; Quit operation if the user enters "^" or times out SD*5.3*563 "RTN","SCMCQK2",36,0) I Y=1 D ASTM G NPC "RTN","SCMCQK2",37,0) READ S:CNT=1 X=1 I CNT>1 W !,"Select 1-"_CNT_": " R X:DTIME Q:X=U S X=+X I X>CNT!X<1 G READ "RTN","SCMCQK2",38,0) I Y=3 S DATA=DATA(+X) S SCTPSTAT=1,SCTP=+$P(DATA,U,2),SCTM=+DATA D UNTP:SCTP,UNTM:'SCTP G NPC "RTN","SCMCQK2",39,0) S DATA=DATA(+X),SCTM=+DATA S SCSELECT=$$SELPOS() G NPC:'$L(SCSELECT) D ASTP G NPC "RTN","SCMCQK2",40,0) Q "RTN","SCMCQK2",41,0) UNTP ;unassign patient from position "RTN","SCMCQK2",42,0) IF '$G(SCTP) W !,"No position defined" Q "RTN","SCMCQK2",43,0) N OK,SCER,SCCL,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS "RTN","SCMCQK2",44,0) S OK=0 "RTN","SCMCQK2",45,0) W !,"About to Unassign "_$$NAME(DFN)_" from: ",!,?8,$$POSITION(SCTP)_" position ["_$P($$GETPRTP^SCAPMCU2(SCTP,DT),U,2)_"]" "RTN","SCMCQK2",46,0) S SCDISCH=$$DATE("D",DFN) ;SD*5.3*563 Pass DFN "RTN","SCMCQK2",47,0) G:SCDISCH<1 QTUNTP "RTN","SCMCQK2",48,0) G:'$$CONFIRM() QTUNTP "RTN","SCMCQK2",49,0) S OK=$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER) "RTN","SCMCQK2",50,0) G:OK'>0 QTUNTP "RTN","SCMCQK2",51,0) S SCCL=$P($G(^SCTM(404.57,+$G(SCTP),0)),U,9) "RTN","SCMCQK2",52,0) QTUNTP W !,"Position Unassignment "_$S(OK:"made.",1:"NOT made.") "RTN","SCMCQK2",53,0) Q "RTN","SCMCQK2",54,0) ; "RTN","SCMCQK2",55,0) ; "RTN","SCMCQK2",56,0) UNTM ; "RTN","SCMCQK2",57,0) ;assign patient from non pc team (and pc position if possible) "RTN","SCMCQK2",58,0) N OK,SCER,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS,OK2,OK3 "RTN","SCMCQK2",59,0) S OK=0 "RTN","SCMCQK2",60,0) W !!,"About to Unassign "_$$NAME(DFN)_" from "_$$TEAMNM(SCTM)_" team" "RTN","SCMCQK2",61,0) W:'SCTPSTAT !,?5,"AND from "_$$POSITION(SCTP)_" position ["_$$WRITETP^SCMCDD1(SCTP)_"]" "RTN","SCMCQK2",62,0) S SCDISCH=$$DATE("D",DFN) ;SD*5.3*563 Pass DFN "RTN","SCMCQK2",63,0) G:SCDISCH<1 QTUNTM "RTN","SCMCQK2",64,0) G:'$$CONFIRM() QTUNTM "RTN","SCMCQK2",65,0) IF 'SCTPSTAT D G:OK2'>0 QTUNTM "RTN","SCMCQK2",66,0) .W !,"Unassigned." "RTN","SCMCQK2",67,0) .S OK2=$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER) "RTN","SCMCQK2",68,0) .IF OK2>0 D "RTN","SCMCQK2",69,0) ..W "made." "RTN","SCMCQK2",70,0) ..S SCCL=$P(^SCTM(404.57,SCTP,0),U,9) "RTN","SCMCQK2",71,0) S OK3=$$ALLPOS^SCMCQK1() "RTN","SCMCQK2",72,0) IF $$OKINPTTM^SCMCTMU2(DFN,SCTM,SCDISCH) D "RTN","SCMCQK2",73,0) .S OK=$$INPTSCTM^SCAPMC7(DFN,SCTM,SCDISCH,.SCER) "RTN","SCMCQK2",74,0) ELSE D "RTN","SCMCQK2",75,0) . W !,"Future/Current Patient-Position Assignment exists" "RTN","SCMCQK2",76,0) QTUNTM W !,"Team Unassignment "_$S(OK:"made",1:"NOT made.") "RTN","SCMCQK2",77,0) Q "RTN","SCMCQK2",78,0) ; "RTN","SCMCQK2",79,0) ASTM ;assign patient to team "RTN","SCMCQK2",80,0) N DIC,Y,OK,SCTM,SCTMFLDS,SCER,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS "RTN","SCMCQK2",81,0) S OK=0 "RTN","SCMCQK2",82,0) W !!,"About to Assign "_$$NAME(DFN)_" to a non primary care team" "RTN","SCMCQK2",83,0) I $$SC^SCMCQK1(DFN) W !!,"********** This patient is 50 percent or greater service-connected ************" "RTN","SCMCQK2",84,0) S DIC="^SCTM(404.51," "RTN","SCMCQK2",85,0) S DIC(0)="AEMQZ" "RTN","SCMCQK2",86,0) S DIC("S")="IF $$ACTTM^SCMCTMU(Y,DT) I $$NEW^SCMCQK2()" "RTN","SCMCQK2",87,0) ; - select from active teams that can not be PC Teams "RTN","SCMCQK2",88,0) D ^DIC "RTN","SCMCQK2",89,0) G:Y<1 QTASTM "RTN","SCMCQK2",90,0) S SCTM=+Y "RTN","SCMCQK2",91,0) S SCASSDT=$$DATE("A",DFN) ;SD*5.3*563 Pass DFN "RTN","SCMCQK2",92,0) G:SCASSDT<1 QTASTM "RTN","SCMCQK2",93,0) S SCTMCT=$$TEAMCNT^SCAPMCU1(SCTM) "RTN","SCMCQK2",94,0) S SCTMMAX=$P($$GETEAM^SCAPMCU3(SCTM),"^",8) "RTN","SCMCQK2",95,0) I SCTMCT'0 "RTN","SCMCQK2",171,0) ; "RTN","SCMCQK2",172,0) YESNO2() ; "RTN","SCMCQK2",173,0) N DIR,X,Y "RTN","SCMCQK2",174,0) S DIR(0)="Y",DIR("B")="NO" "RTN","SCMCQK2",175,0) S DIR("A")="Do you wish to continue with the assignment (Yes/No)?" "RTN","SCMCQK2",176,0) D ^DIR "RTN","SCMCQK2",177,0) Q Y>0 "RTN","SCMCQK2",178,0) CONFIRM() ;confirmation call "RTN","SCMCQK2",179,0) N DIR,X,Y "RTN","SCMCQK2",180,0) S DIR("A")="Are you sure (Yes/No)" "RTN","SCMCQK2",181,0) S DIR(0)="Y" "RTN","SCMCQK2",182,0) D ^DIR "RTN","SCMCQK2",183,0) Q +Y=1 "RTN","SCMCQK2",184,0) ; "RTN","SCMCQK2",185,0) SELPOS() ;return way to select position: 1=PRACT,2=POSIT,3=NONE "RTN","SCMCQK2",186,0) N DIR,X,Y "RTN","SCMCQK2",187,0) W !,"Choose way to select NON PC POSITION Assignment: " "RTN","SCMCQK2",188,0) S DIR(0)="SO^0:NONE;1:BY PRACTITIONER ASSIGNMENT;2:BY POSITION ASSIGNMENT" "RTN","SCMCQK2",189,0) S DIR("B")=1 "RTN","SCMCQK2",190,0) D ^DIR "RTN","SCMCQK2",191,0) Q $S(Y'>0:"",+Y=1:"PRACT",1:"POSIT") "RTN","SCMCQK2",192,0) ; "RTN","SCMCQK2",193,0) DATE(TYPE,DFN) ;type=A(Assignment) or D(Unassignment) "RTN","SCMCQK2",194,0) ; Returns assignment/unassignment date or "^" "RTN","SCMCQK2",195,0) I '$G(DFN) Q -1 "RTN","SCMCQK2",196,0) N DIR,X,Y,SDFLG,SDY "RTN","SCMCQK2",197,0) ;SD*5.3*563 SDFLG=0 allow to proceed with date if prior to DOD "RTN","SCMCQK2",198,0) F D Q:SDFLG=0 "RTN","SCMCQK2",199,0) .S DIR("A")=$S(TYPE="A":"Assignment",1:"Unassignment")_" date: " "RTN","SCMCQK2",200,0) .S DIR(0)="DA^::EXP" "RTN","SCMCQK2",201,0) .S Y=$S($D(SCDISCH):SCDISCH,$D(SCASSDT):SCASSDT,(TYPE="A"):"TODAY",1:"TODAY-1") "RTN","SCMCQK2",202,0) .X ^DD("DD") "RTN","SCMCQK2",203,0) .S DIR("B")=Y "RTN","SCMCQK2",204,0) .D ^DIR K DIR S SDY=Y "RTN","SCMCQK2",205,0) .I $D(DIRUT) K DIRUT,DUOUT,X,Y S SDFLG=0 Q "RTN","SCMCQK2",206,0) .D WARNMESS^SCMCQK1(SDY,DFN,.SDFLG) "RTN","SCMCQK2",207,0) Q SDY "RTN","SCMCQK2",208,0) PRACSCR(SC40452) ;screen for for file 404.52 "RTN","SCMCQK2",209,0) N SCP,SCNODE,OK "RTN","SCMCQK2",210,0) S SCP=$G(^SCTM(404.52,SC40452,0)) "RTN","SCMCQK2",211,0) S OK=0 "RTN","SCMCQK2",212,0) G:'SCP QTPP "RTN","SCMCQK2",213,0) S SCNODE=$G(^SCTM(404.57,+SCP,0)) "RTN","SCMCQK2",214,0) S OK=$S($P(SCNODE,U,2)'=SCTM:0,$P(SCNODE,U,4):0,($O(^SCTM(404.52,"AIDT",+SCP,1,""))'=-$P(SCP,U,2)):0,($O(^SCTM(404.52,"AIDT",+SCP,0,-$P(SCP,U,2)),-1)):0,($$ACTTP^SCMCTPU(+SCP)>0):1,1:0) "RTN","SCMCQK2",215,0) QTPP Q OK "RTN","SCMCQK2",216,0) ; "RTN","SCMCQK2",217,0) POSSCR(SCTP) ;screen for file 404.57 "RTN","SCMCQK2",218,0) N SCNODE "RTN","SCMCQK2",219,0) S SCNODE=$G(^SCTM(404.57,SCTP,0)) "RTN","SCMCQK2",220,0) Q $S($P(SCNODE,U,2)'=SCTM:0,$P(SCNODE,U,4):0,($$ACTTP^SCMCTPU(SCTP)>0):1,1:0) "RTN","SCMCQK2",221,0) Q "RTN","SCMCQK2",222,0) NEW() ; "RTN","SCMCQK2",223,0) F I=0:0 S I=$O(SCD(I)) Q:'I I (+SCD(I))=(+Y) Q "RTN","SCMCQK2",224,0) Q 'I "VER") 8.0^22.0 "BLD",8237,6) ^492 **END** **END**