SCMCTSKG ;bpoifo/dmr PCMM Inactivation GUI Rpt.;3/18/08
;;5.3;Scheduling;**504**;AUG 13, 1993;Build 21
;;
EN(SCRESULT,SCARRAY) ;
S (STAT,TN,IEN,INST,INSTN,UNDATE,UNREA,TEAMPN,SSN,SSNN)="" S NUM=0
S (TEAM,TEAMP,PROVN,PROV,BDATE,EDATE,PAT,INAME,HOLD)="" S NN=0,CC=0,CT=0
K ^TMP("SCARRAY")
M ^TMP("SCARRAY")=SCARRAY
D DATE
K ^TMP("SCRESULT","B")
D FINAL
S SCRESULT=$NA(^TMP("SCRESULT"))
D EXIT
Q
DATE ;
S BDATE=$G(^TMP("SCARRAY","AA")) S X=$P(BDATE,"""",2) D ^%DT S BDATE=Y
S EDATE=$G(^TMP("SCARRAY","AB")) S X=$P(EDATE,"""",2) D ^%DT S EDATE=Y
D START
Q
START ;
S STAT="" F S STAT=$O(^SCPT(404.43,"ASTATB",STAT)) Q:STAT="" D
.S IEN="" F S IEN=$O(^SCPT(404.43,"ASTATB",STAT,IEN)) Q:'IEN D
..S UNDATE="" S UNDATE=$$GET1^DIQ(404.43,IEN_",",.04,"I") IF $D(UNDATE) D
...I (UNDATE<BDATE)!(UNDATE>EDATE) Q
...S PAT="" S PAT=$$GET1^DIQ(404.43,IEN_",",.01)
...S (SN,SSN,SSNN)="" S SN=$$GET1^DIQ(404.43,IEN_",",.01,"I")
...S SSNN=$$GET1^DIQ(404.42,SN_",",.01,"I") S SSN=$$GET1^DIQ(2,SSNN_",",.09)
...D TEAMP
...Q
Q
TEAMP ;
S (TEAMP,TPN,TPN2)=""
S TPN=$$GET1^DIQ(404.43,IEN_",",.02,"I")
S TEAMP=$$GET1^DIQ(404.43,IEN_",",.02)
I $G(^TMP("SCARRAY","TP^0"))="""ALL^0""" D TEAM Q
I '$D(^TMP("SCARRAY","TP^0")) D
.S TPN2=$G(^TMP("SCARRAY","TP^"_TPN)) I TPN2'="" D
..S TPN2=$P(TPN2,"""",2) I $P(TPN2,"^",1)=TEAMP D TEAM
Q
TEAM ;
S (TEAMN,TN,TN2,PREC)=""
S TN=$$GET1^DIQ(404.57,TPN_",",.02,"I")
S TEAMN=$$GET1^DIQ(404.57,TPN_",",.02)
S PREC=$$GET1^DIQ(404.57,TPN_",",.1)
I $G(^TMP("SCARRAY","T^0"))="""ALL^0""" D INST
I '$D(^TMP("SCARRAY","T^0")) D
.S TN2=$G(^TMP("SCARRAY","T^"_TN)) I TN2'="" D
..S TN2=$P(TN2,"""",2),TN2=$P(TN2,"^",1)
..I TN2=TEAMN D INST
Q
INST ;
S (INST,INSTN,INUM)=""
S INSTN=$$GET1^DIQ(404.51,TN_",",.07,"I")
I $G(^TMP("SCARRAY","D^0"))="""ALL^0""" D
.S INST=$$GET1^DIQ(404.51,TN_",",.07)
.D PROV
.Q
I $G(^TMP("SCARRAY","D^0"))'="""ALL""" D
.S INUM=$G(^TMP("SCARRAY","D^"_INSTN)) I INUM'="" D
..S INUM=$P(INUM,"""",2)
..I $P(INUM,"^",2)=INSTN D
...S INST=$$GET1^DIQ(404.51,TN_",",.07)
...D PROV
...Q
Q
PROV ;
S (PROV,PROVN,J,JJ,PDATE,EFFD,SCLIST,ERROR,FILE,ST,P1,P2,P3)=""
I $G(^TMP("SCARRAY","P^0"))'="""ALL^0""" D
.S J="N" F S J=$O(^TMP("SCARRAY",J)) Q:J="" D
..Q:$P(J,"^",1)'="P" D
...S PROVN="" S PROVN=+$P(^TMP("SCARRAY",J),"^",2) D
....S JJ="" F S JJ=$O(^SCTM(404.52,"C",PROVN,JJ)) Q:'JJ D
.....S POS="" S POS=$$GET1^DIQ(404.52,JJ_",",.01) I POS=TEAMP D
......S (PDATE,ST)="" S PDATE=$$GET1^DIQ(404.52,JJ_",",.02,"I"),ST=$$GET1^DIQ(404.52,JJ_",",.04,"I") D
.......I PDATE>UNDATE Q
.......I ST=0&(PDATE<UNDATE) Q
.......S PROV="" S PROV=$$GET1^DIQ(404.52,JJ_",",.03)
.......D UNREA,SAVE
.......Q
I $G(^TMP("SCARRAY","P^0"))="""ALL^0""" D
.S PROVN="" F S PROVN=$O(^SCTM(404.52,"C",PROVN)) Q:PROVN="" D
..S JJ="" F S JJ=$O(^SCTM(404.52,"C",PROVN,JJ)) Q:'JJ D
...S POS="" S POS=$$GET1^DIQ(404.52,JJ_",",.01) I POS=TEAMP D
....S (PDATE,ST)="" S PDATE=$$GET1^DIQ(404.52,JJ_",",.02,"I"),ST=$$GET1^DIQ(404.52,JJ_",",.04,"I") D
.....I PDATE>UNDATE Q
.....I ST=0&(PDATE<UNDATE) Q
.....S PROV="" S PROV=$$GET1^DIQ(404.52,JJ_",",.03)
.....D UNREA,SAVE
.....Q
Q
UNREA ;Unassign Reason
S UNREA=""
S UNREA=$$GET1^DIQ(404.43,IEN_",",.12,"I")
Q
SAVE ;
I $G(^TMP("SCARRAY","S1"))="""ALL""" D SAVE1 Q
I $G(^TMP("SCARRAY","S1"))'="""ALL""" D SAVE2,SAVE3
Q
SAVE1 ;
S Y=UNDATE D DD^%DT S UNDATE=Y
S NUM=NUM+1
S ^TMP("SCRESULT",INST,PAT,NUM)=PAT_"^"_SSN_"^"_INST_"^"_TEAMN_"^"_PROV_"^"_TEAMP_"^"_PREC_"^"_UNDATE_"^"_UNREA
Q
SAVE2 ;
S (S1,S2,S3,S4,S5,S6,S7)="",CC="",SORT=""
F NN=1:1:7 S SORT=$G(^TMP("SCARRAY","S"_NN)) Q:SORT="" D
.S SORT=$P(SORT,"""",2)
.S XX=$S(SORT="Patient":PAT,SORT="Institution":INST,SORT="Team":TEAMN,SORT="Provider":PROV,SORT="Team Position":TEAMP,SORT="Date":UNDATE,SORT="Reason":UNREA,1:"")
.S HOLD=NN
.I NN=1 S S1=XX,^TMP("SCRESULT",S1)=""
.I NN=2 S S2=XX,^TMP("SCRESULT",S1,S2)=""
.I NN=3 S S3=XX,^TMP("SCRESULT",S1,S2,S3)=""
.I NN=4 S S4=XX,^TMP("SCRESULT",S1,S2,S3,S4)=""
.I NN=5 S S5=XX,^TMP("SCRESULT",S1,S2,S3,S4,S5)=""
.I NN=6 S S6=XX,^TMP("SCRESULT",S1,S2,S3,S4,S5,S6)=""
.I NN=7 S S7=XX,^TMP("SCRESULT",S1,S2,S3,S4,S5,S6,S7)=""
Q
SAVE3 ;
S CC=$S(HOLD=1:"SORT1",HOLD=2:"SORT2",HOLD=3:"SORT3",HOLD=4:"SORT4",HOLD=5:"SORT5",HOLD=6:"SORT6",HOLD=7:"SORT7",1:"")
S UNDATE2="" S UNDATE2=UNDATE
S Y=UNDATE2 D DD^%DT S UNDATE2=Y
D @CC
Q
SORT1 ;
I $D(^TMP("SCRESULT","B",PAT,SSN,INST,TEAMN)) Q
S CT=CT+1
S ^TMP("SCRESULT",S1,CT)=PAT_"^"_SSN_"^"_INST_"^"_TEAMN_"^"_PROV_"^"_TEAMP_"^"_PREC_"^"_UNDATE2_"^"_UNREA
S ^TMP("SCRESULT","B",PAT,SSN,INST,TEAMN)=""
Q
SORT2 ;
I $D(^TMP("SCRESULT","B",PAT,SSN,INST,TEAMN)) Q
S CT=CT+1
S ^TMP("SCRESULT",S1,S2,CT)=PAT_"^"_SSN_"^"_INST_"^"_TEAMN_"^"_PROV_"^"_TEAMP_"^"_PREC_"^"_UNDATE2_"^"_UNREA
S ^TMP("SCRESULT","B",PAT,SSN,INST,TEAMN)=""
Q
SORT3 ;
I $D(^TMP("SCRESULT","B",PAT,SSN,INST,TEAMN)) Q
S CT=CT+1
S ^TMP("SCRESULT",S1,S2,S3,CT)=PAT_"^"_SSN_"^"_INST_"^"_TEAMN_"^"_PROV_"^"_TEAMP_"^"_PREC_"^"_UNDATE2_"^"_UNREA
S ^TMP("SCRESULT","B",PAT,SSN,INST,TEAMN)=""
Q
SORT4 ;
I $D(^TMP("SCRESULT","B",PAT,SSN,INST,TEAMN)) Q
S CT=CT+1
S ^TMP("SCRESULT",S1,S2,S3,S4,CT)=PAT_"^"_SSN_"^"_INST_"^"_TEAMN_"^"_PROV_"^"_TEAMP_"^"_PREC_"^"_UNDATE2_"^"_UNREA
S ^TMP("SCRESULT","B",PAT,SSN,INST,TEAMN)=""
Q
SORT5 ;
I $D(^TMP("SCRESULT","B",PAT,SSN,INST,TEAMN)) Q
S CT=CT+1
S ^TMP("SCRESULT",S1,S2,S3,S4,S5,CT)=PAT_"^"_SSN_"^"_INST_"^"_TEAMN_"^"_PROV_"^"_TEAMP_"^"_PREC_"^"_UNDATE2_"^"_UNREA
S ^TMP("SCRESULT","B",PAT,SSN,INST,TEAMN)=""
Q
SORT6 ;
I $D(^TMP("SCRESULT","B",PAT,SSN,INST,TEAMN)) Q
S CT=CT+1
S ^TMP("SCRESULT",S1,S2,S3,S4,S5,S6,CT)=PAT_"^"_SSN_"^"_INST_"^"_TEAMN_"^"_PROV_"^"_TEAMP_"^"_PREC_"^"_UNDATE2_"^"_UNREA
S ^TMP("SCRESULT","B",PAT,SSN,INST,TEAMN)=""
Q
SORT7 ;
I $D(^TMP("SCRESULT","B",PAT,SSN,INST,TEAMN)) Q
S CT=CT+1
S ^TMP("SCRESULT",S1,S2,S3,S4,S5,S6,S7,CT)=PAT_"^"_SSN_"^"_INST_"^"_TEAMN_"^"_PROV_"^"_TEAMP_"^"_PREC_"^"_UNDATE2_"^"_UNREA
S ^TMP("SCRESULT","B",PAT,SSN,INST,TEAMN)=""
Q
FINAL ;
I $G(^TMP("SCARRAY","S1"))="""ALL""" D
.S (INST,PAT,NUM)="" S CC=0,C=0
.S INST="" F S INST=$O(^TMP("SCRESULT",INST)) Q:INST="" D
..S PAT="" F S PAT=$O(^TMP("SCRESULT",INST,PAT)) Q:PAT="" D
...S NUM="" F S NUM=$O(^TMP("SCRESULT",INST,PAT,NUM)) Q:NUM="" D
....S CC=CC+1 S ^TMP("SCRESULT",CC)=^TMP("SCRESULT",INST,PAT,NUM)
....K ^TMP("SCRESULT",INST,PAT,NUM)
I $G(^TMP("SCARRAY","S1"))'="""ALL""" D
.S (S1,S2,S3,S4,S5,S6,S7)="",CT=0,C=0
.IF CC="SORT1" D
..S S1="" F S S1=$O(^TMP("SCRESULT",S1)) Q:S1="" D
...S C="" F S C=$O(^TMP("SCRESULT",S1,C)) Q:C="" D
....S CT=CT+1 S ^TMP("SCRESULT",CT)=^TMP("SCRESULT",S1,C)
....K ^TMP("SCRESULT",S1,C)
.I CC="SORT2" D
..S S1="" F S S1=$O(^TMP("SCRESULT",S1)) Q:S1="" D
...S S2="" F S S2=$O(^TMP("SCRESULT",S1,S2)) Q:S2="" D
....S C="" F S C=$O(^TMP("SCRESULT",S1,S2,C)) Q:C="" D
.....S CT=CT+1 S ^TMP("SCRESULT",CT)=^TMP("SCRESULT",S1,S2,C)
.....K ^TMP("SCRESULT",S1,S2,C)
.I CC="SORT3" D
..S S1="" F S S1=$O(^TMP("SCRESULT",S1)) Q:S1="" D
...S S2="" F S S2=$O(^TMP("SCRESULT",S1,S2)) Q:S2="" D
....S S3="" F S S3=$O(^TMP("SCRESULT",S1,S2,S3)) Q:S3="" D
.....S C="" F S C=$O(^TMP("SCRESULT",S1,S2,S3,C)) Q:C="" D
......S CT=CT+1 S ^TMP("SCRESULT",CT)=^TMP("SCRESULT",S1,S2,S3,C)
......K ^TMP("SCRESULT",S1,S2,S3,C)
.I CC="SORT4" D
..S S1="" F S S1=$O(^TMP("SCRESULT",S1)) Q:S1="" D
...S S2="" F S S2=$O(^TMP("SCRESULT",S1,S2)) Q:S2="" D
....S S3="" F S S3=$O(^TMP("SCRESULT",S1,S2,S3)) Q:S3="" D
.....S S4="" F S S4=$O(^TMP("SCRESULT",S1,S2,S3,S4)) Q:S4="" D
......S C="" F S C=$O(^TMP("SCRESULT",S1,S2,S3,S4,C)) Q:C="" D
.......S CT=CT+1 S ^TMP("SCRESULT",CT)=^TMP("SCRESULT",S1,S2,S3,S4,C)
.......K ^TMP("SCRESULT",S1,S2,S3,S4,C)
.I CC="SORT5" D
..S S1="" F S S1=$O(^TMP("SCRESULT",S1)) Q:S1="" D
...S S2="" F S S2=$O(^TMP("SCRESULT",S1,S2)) Q:S2="" D
....S S3="" F S S3=$O(^TMP("SCRESULT",S1,S2,S3)) Q:S3="" D
.....S S4="" F S S4=$O(^TMP("SCRESULT",S1,S2,S3,S4)) Q:S4="" D
......S S5="" F S S5=$O(^TMP("SCRESULT",S1,S2,S3,S4,S5)) Q:S5="" D
.......S C="" F S C=$O(^TMP("SCRESULT",S1,S2,S3,S4,S5,C)) Q:C="" D
........S CT=CT+1 S ^TMP("SCRESULT",CT)=^TMP("SCRESULT",S1,S2,S3,S4,S5,C)
........K ^TMP("SCRESULT",S1,S2,S3,S4,S5,C)
.I CC="SORT6" D
..S S1="" F S S1=$O(^TMP("SCRESULT",S1)) Q:S1="" D
...S S2="" F S S2=$O(^TMP("SCRESULT",S1,S2)) Q:S2="" D
....S S3="" F S S3=$O(^TMP("SCRESULT",S1,S2,S3)) Q:S3="" D
.....S S4="" F S S4=$O(^TMP("SCRESULT",S1,S2,S3,S4)) Q:S4="" D
......S S5="" F S S5=$O(^TMP("SCRESULT",S1,S2,S3,S4,S5)) Q:S5="" D
.......S S6="" F S S6=$O(^TMP("SCRESULT",S1,S2,S3,S4,S5,S6)) Q:S6="" D
........S C="" F S C=$O(^TMP("SCRESULT",S1,S2,S3,S4,S5,S6,C)) Q:C="" D
.........S CT=CT+1 S ^TMP("SCRESULT",CT)=^TMP("SCRESULT",S1,S2,S3,S4,S5,S6,C)
.........K ^TMP("SCRESULT",S1,S2,S3,S4,S5,S6,C)
.I CC="SORT7" D
..S S1="" F S S1=$O(^TMP("SCRESULT",S1)) Q:S1="" D
...S S2="" F S S2=$O(^TMP("SCRESULT",S1,S2)) Q:S2="" D
....S S3="" F S S3=$O(^TMP("SCRESULT",S1,S2,S3)) Q:S3="" D
.....S S4="" F S S4=$O(^TMP("SCRESULT",S1,S2,S3,S4)) Q:S4="" D
......S S5="" F S S5=$O(^TMP("SCRESULT",S1,S2,S3,S4,S5)) Q:S5="" D
.......S S6="" F S S6=$O(^TMP("SCRESULT",S1,S2,S3,S4,S5,S6)) Q:S6="" D
........S S7="" F S S7=$O(^TMP("SCRESULT",S1,S2,S3,S4,S5,S6,S7)) Q:S7="" D
.........S C="" F S C=$O(^TMP("SCRESULT",S1,S2,S3,S4,S5,S6,S7,C)) Q:C="" D
..........S CT=CT+1 S ^TMP("SCRESULT",CT)=^TMP("SCRESULT",S1,S2,S3,S4,S5,S6,S7,C)
..........K ^TMP("SCRESULT",S1,S2,S3,S4,S5,S6,S7,C)
Q
EXIT ;
K STAT,TN,TPN,IEN,INST,INSTN,UNDATE,UNREA,TEAMPN,SSN,SSNN,S1,S2,S3,S4,S5,S6,S7,S8
K TEAM,TEAMN,TEAMP,PROVN,PROV,BDATE,EDATE,PAT,INAME,HOLD,NUM,NU,CC,C,CT,XX,ST
K TN2,TPN2,UNDATE2,DATE2,EFFD,ERROR,SORT,SN,PDATE,POS,PREC,JJ,J,INUM,NN,P1,P2,P3
K ^TMP("SCARRAY")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMCTSKG 10080 printed Sep 23, 2025@20:18:01 Page 2
SCMCTSKG ;bpoifo/dmr PCMM Inactivation GUI Rpt.;3/18/08
+1 ;;5.3;Scheduling;**504**;AUG 13, 1993;Build 21
+2 ;;
EN(SCRESULT,SCARRAY) ;
+1 SET (STAT,TN,IEN,INST,INSTN,UNDATE,UNREA,TEAMPN,SSN,SSNN)=""
SET NUM=0
+2 SET (TEAM,TEAMP,PROVN,PROV,BDATE,EDATE,PAT,INAME,HOLD)=""
SET NN=0
SET CC=0
SET CT=0
+3 KILL ^TMP("SCARRAY")
+4 MERGE ^TMP("SCARRAY")=SCARRAY
+5 DO DATE
+6 KILL ^TMP("SCRESULT","B")
+7 DO FINAL
+8 SET SCRESULT=$NAME(^TMP("SCRESULT"))
+9 DO EXIT
+10 QUIT
DATE ;
+1 SET BDATE=$GET(^TMP("SCARRAY","AA"))
SET X=$PIECE(BDATE,"""",2)
DO ^%DT
SET BDATE=Y
+2 SET EDATE=$GET(^TMP("SCARRAY","AB"))
SET X=$PIECE(EDATE,"""",2)
DO ^%DT
SET EDATE=Y
+3 DO START
+4 QUIT
START ;
+1 SET STAT=""
FOR
SET STAT=$ORDER(^SCPT(404.43,"ASTATB",STAT))
if STAT=""
QUIT
Begin DoDot:1
+2 SET IEN=""
FOR
SET IEN=$ORDER(^SCPT(404.43,"ASTATB",STAT,IEN))
if 'IEN
QUIT
Begin DoDot:2
+3 SET UNDATE=""
SET UNDATE=$$GET1^DIQ(404.43,IEN_",",.04,"I")
IF $DATA(UNDATE)
Begin DoDot:3
+4 IF (UNDATE<BDATE)!(UNDATE>EDATE)
QUIT
+5 SET PAT=""
SET PAT=$$GET1^DIQ(404.43,IEN_",",.01)
+6 SET (SN,SSN,SSNN)=""
SET SN=$$GET1^DIQ(404.43,IEN_",",.01,"I")
+7 SET SSNN=$$GET1^DIQ(404.42,SN_",",.01,"I")
SET SSN=$$GET1^DIQ(2,SSNN_",",.09)
+8 DO TEAMP
+9 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+10 QUIT
TEAMP ;
+1 SET (TEAMP,TPN,TPN2)=""
+2 SET TPN=$$GET1^DIQ(404.43,IEN_",",.02,"I")
+3 SET TEAMP=$$GET1^DIQ(404.43,IEN_",",.02)
+4 IF $GET(^TMP("SCARRAY","TP^0"))="""ALL^0"""
DO TEAM
QUIT
+5 IF '$DATA(^TMP("SCARRAY","TP^0"))
Begin DoDot:1
+6 SET TPN2=$GET(^TMP("SCARRAY","TP^"_TPN))
IF TPN2'=""
Begin DoDot:2
+7 SET TPN2=$PIECE(TPN2,"""",2)
IF $PIECE(TPN2,"^",1)=TEAMP
DO TEAM
End DoDot:2
End DoDot:1
+8 QUIT
TEAM ;
+1 SET (TEAMN,TN,TN2,PREC)=""
+2 SET TN=$$GET1^DIQ(404.57,TPN_",",.02,"I")
+3 SET TEAMN=$$GET1^DIQ(404.57,TPN_",",.02)
+4 SET PREC=$$GET1^DIQ(404.57,TPN_",",.1)
+5 IF $GET(^TMP("SCARRAY","T^0"))="""ALL^0"""
DO INST
+6 IF '$DATA(^TMP("SCARRAY","T^0"))
Begin DoDot:1
+7 SET TN2=$GET(^TMP("SCARRAY","T^"_TN))
IF TN2'=""
Begin DoDot:2
+8 SET TN2=$PIECE(TN2,"""",2)
SET TN2=$PIECE(TN2,"^",1)
+9 IF TN2=TEAMN
DO INST
End DoDot:2
End DoDot:1
+10 QUIT
INST ;
+1 SET (INST,INSTN,INUM)=""
+2 SET INSTN=$$GET1^DIQ(404.51,TN_",",.07,"I")
+3 IF $GET(^TMP("SCARRAY","D^0"))="""ALL^0"""
Begin DoDot:1
+4 SET INST=$$GET1^DIQ(404.51,TN_",",.07)
+5 DO PROV
+6 QUIT
End DoDot:1
+7 IF $GET(^TMP("SCARRAY","D^0"))'="""ALL"""
Begin DoDot:1
+8 SET INUM=$GET(^TMP("SCARRAY","D^"_INSTN))
IF INUM'=""
Begin DoDot:2
+9 SET INUM=$PIECE(INUM,"""",2)
+10 IF $PIECE(INUM,"^",2)=INSTN
Begin DoDot:3
+11 SET INST=$$GET1^DIQ(404.51,TN_",",.07)
+12 DO PROV
+13 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+14 QUIT
PROV ;
+1 SET (PROV,PROVN,J,JJ,PDATE,EFFD,SCLIST,ERROR,FILE,ST,P1,P2,P3)=""
+2 IF $GET(^TMP("SCARRAY","P^0"))'="""ALL^0"""
Begin DoDot:1
+3 SET J="N"
FOR
SET J=$ORDER(^TMP("SCARRAY",J))
if J=""
QUIT
Begin DoDot:2
+4 if $PIECE(J,"^",1)'="P"
QUIT
Begin DoDot:3
+5 SET PROVN=""
SET PROVN=+$PIECE(^TMP("SCARRAY",J),"^",2)
Begin DoDot:4
+6 SET JJ=""
FOR
SET JJ=$ORDER(^SCTM(404.52,"C",PROVN,JJ))
if 'JJ
QUIT
Begin DoDot:5
+7 SET POS=""
SET POS=$$GET1^DIQ(404.52,JJ_",",.01)
IF POS=TEAMP
Begin DoDot:6
+8 SET (PDATE,ST)=""
SET PDATE=$$GET1^DIQ(404.52,JJ_",",.02,"I")
SET ST=$$GET1^DIQ(404.52,JJ_",",.04,"I")
Begin DoDot:7
+9 IF PDATE>UNDATE
QUIT
+10 IF ST=0&(PDATE<UNDATE)
QUIT
+11 SET PROV=""
SET PROV=$$GET1^DIQ(404.52,JJ_",",.03)
+12 DO UNREA
DO SAVE
+13 QUIT
End DoDot:7
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+14 IF $GET(^TMP("SCARRAY","P^0"))="""ALL^0"""
Begin DoDot:1
+15 SET PROVN=""
FOR
SET PROVN=$ORDER(^SCTM(404.52,"C",PROVN))
if PROVN=""
QUIT
Begin DoDot:2
+16 SET JJ=""
FOR
SET JJ=$ORDER(^SCTM(404.52,"C",PROVN,JJ))
if 'JJ
QUIT
Begin DoDot:3
+17 SET POS=""
SET POS=$$GET1^DIQ(404.52,JJ_",",.01)
IF POS=TEAMP
Begin DoDot:4
+18 SET (PDATE,ST)=""
SET PDATE=$$GET1^DIQ(404.52,JJ_",",.02,"I")
SET ST=$$GET1^DIQ(404.52,JJ_",",.04,"I")
Begin DoDot:5
+19 IF PDATE>UNDATE
QUIT
+20 IF ST=0&(PDATE<UNDATE)
QUIT
+21 SET PROV=""
SET PROV=$$GET1^DIQ(404.52,JJ_",",.03)
+22 DO UNREA
DO SAVE
+23 QUIT
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+24 QUIT
UNREA ;Unassign Reason
+1 SET UNREA=""
+2 SET UNREA=$$GET1^DIQ(404.43,IEN_",",.12,"I")
+3 QUIT
SAVE ;
+1 IF $GET(^TMP("SCARRAY","S1"))="""ALL"""
DO SAVE1
QUIT
+2 IF $GET(^TMP("SCARRAY","S1"))'="""ALL"""
DO SAVE2
DO SAVE3
+3 QUIT
SAVE1 ;
+1 SET Y=UNDATE
DO DD^%DT
SET UNDATE=Y
+2 SET NUM=NUM+1
+3 SET ^TMP("SCRESULT",INST,PAT,NUM)=PAT_"^"_SSN_"^"_INST_"^"_TEAMN_"^"_PROV_"^"_TEAMP_"^"_PREC_"^"_UNDATE_"^"_UNREA
+4 QUIT
SAVE2 ;
+1 SET (S1,S2,S3,S4,S5,S6,S7)=""
SET CC=""
SET SORT=""
+2 FOR NN=1:1:7
SET SORT=$GET(^TMP("SCARRAY","S"_NN))
if SORT=""
QUIT
Begin DoDot:1
+3 SET SORT=$PIECE(SORT,"""",2)
+4 SET XX=$SELECT(SORT="Patient":PAT,SORT="Institution":INST,SORT="Team":TEAMN,SORT="Provider":PROV,SORT="Team Position":TEAMP,SORT="Date":UNDATE,SORT="Reason":UNREA,1:"")
+5 SET HOLD=NN
+6 IF NN=1
SET S1=XX
SET ^TMP("SCRESULT",S1)=""
+7 IF NN=2
SET S2=XX
SET ^TMP("SCRESULT",S1,S2)=""
+8 IF NN=3
SET S3=XX
SET ^TMP("SCRESULT",S1,S2,S3)=""
+9 IF NN=4
SET S4=XX
SET ^TMP("SCRESULT",S1,S2,S3,S4)=""
+10 IF NN=5
SET S5=XX
SET ^TMP("SCRESULT",S1,S2,S3,S4,S5)=""
+11 IF NN=6
SET S6=XX
SET ^TMP("SCRESULT",S1,S2,S3,S4,S5,S6)=""
+12 IF NN=7
SET S7=XX
SET ^TMP("SCRESULT",S1,S2,S3,S4,S5,S6,S7)=""
End DoDot:1
+13 QUIT
SAVE3 ;
+1 SET CC=$SELECT(HOLD=1:"SORT1",HOLD=2:"SORT2",HOLD=3:"SORT3",HOLD=4:"SORT4",HOLD=5:"SORT5",HOLD=6:"SORT6",HOLD=7:"SORT7",1:"")
+2 SET UNDATE2=""
SET UNDATE2=UNDATE
+3 SET Y=UNDATE2
DO DD^%DT
SET UNDATE2=Y
+4 DO @CC
+5 QUIT
SORT1 ;
+1 IF $DATA(^TMP("SCRESULT","B",PAT,SSN,INST,TEAMN))
QUIT
+2 SET CT=CT+1
+3 SET ^TMP("SCRESULT",S1,CT)=PAT_"^"_SSN_"^"_INST_"^"_TEAMN_"^"_PROV_"^"_TEAMP_"^"_PREC_"^"_UNDATE2_"^"_UNREA
+4 SET ^TMP("SCRESULT","B",PAT,SSN,INST,TEAMN)=""
+5 QUIT
SORT2 ;
+1 IF $DATA(^TMP("SCRESULT","B",PAT,SSN,INST,TEAMN))
QUIT
+2 SET CT=CT+1
+3 SET ^TMP("SCRESULT",S1,S2,CT)=PAT_"^"_SSN_"^"_INST_"^"_TEAMN_"^"_PROV_"^"_TEAMP_"^"_PREC_"^"_UNDATE2_"^"_UNREA
+4 SET ^TMP("SCRESULT","B",PAT,SSN,INST,TEAMN)=""
+5 QUIT
SORT3 ;
+1 IF $DATA(^TMP("SCRESULT","B",PAT,SSN,INST,TEAMN))
QUIT
+2 SET CT=CT+1
+3 SET ^TMP("SCRESULT",S1,S2,S3,CT)=PAT_"^"_SSN_"^"_INST_"^"_TEAMN_"^"_PROV_"^"_TEAMP_"^"_PREC_"^"_UNDATE2_"^"_UNREA
+4 SET ^TMP("SCRESULT","B",PAT,SSN,INST,TEAMN)=""
+5 QUIT
SORT4 ;
+1 IF $DATA(^TMP("SCRESULT","B",PAT,SSN,INST,TEAMN))
QUIT
+2 SET CT=CT+1
+3 SET ^TMP("SCRESULT",S1,S2,S3,S4,CT)=PAT_"^"_SSN_"^"_INST_"^"_TEAMN_"^"_PROV_"^"_TEAMP_"^"_PREC_"^"_UNDATE2_"^"_UNREA
+4 SET ^TMP("SCRESULT","B",PAT,SSN,INST,TEAMN)=""
+5 QUIT
SORT5 ;
+1 IF $DATA(^TMP("SCRESULT","B",PAT,SSN,INST,TEAMN))
QUIT
+2 SET CT=CT+1
+3 SET ^TMP("SCRESULT",S1,S2,S3,S4,S5,CT)=PAT_"^"_SSN_"^"_INST_"^"_TEAMN_"^"_PROV_"^"_TEAMP_"^"_PREC_"^"_UNDATE2_"^"_UNREA
+4 SET ^TMP("SCRESULT","B",PAT,SSN,INST,TEAMN)=""
+5 QUIT
SORT6 ;
+1 IF $DATA(^TMP("SCRESULT","B",PAT,SSN,INST,TEAMN))
QUIT
+2 SET CT=CT+1
+3 SET ^TMP("SCRESULT",S1,S2,S3,S4,S5,S6,CT)=PAT_"^"_SSN_"^"_INST_"^"_TEAMN_"^"_PROV_"^"_TEAMP_"^"_PREC_"^"_UNDATE2_"^"_UNREA
+4 SET ^TMP("SCRESULT","B",PAT,SSN,INST,TEAMN)=""
+5 QUIT
SORT7 ;
+1 IF $DATA(^TMP("SCRESULT","B",PAT,SSN,INST,TEAMN))
QUIT
+2 SET CT=CT+1
+3 SET ^TMP("SCRESULT",S1,S2,S3,S4,S5,S6,S7,CT)=PAT_"^"_SSN_"^"_INST_"^"_TEAMN_"^"_PROV_"^"_TEAMP_"^"_PREC_"^"_UNDATE2_"^"_UNREA
+4 SET ^TMP("SCRESULT","B",PAT,SSN,INST,TEAMN)=""
+5 QUIT
FINAL ;
+1 IF $GET(^TMP("SCARRAY","S1"))="""ALL"""
Begin DoDot:1
+2 SET (INST,PAT,NUM)=""
SET CC=0
SET C=0
+3 SET INST=""
FOR
SET INST=$ORDER(^TMP("SCRESULT",INST))
if INST=""
QUIT
Begin DoDot:2
+4 SET PAT=""
FOR
SET PAT=$ORDER(^TMP("SCRESULT",INST,PAT))
if PAT=""
QUIT
Begin DoDot:3
+5 SET NUM=""
FOR
SET NUM=$ORDER(^TMP("SCRESULT",INST,PAT,NUM))
if NUM=""
QUIT
Begin DoDot:4
+6 SET CC=CC+1
SET ^TMP("SCRESULT",CC)=^TMP("SCRESULT",INST,PAT,NUM)
+7 KILL ^TMP("SCRESULT",INST,PAT,NUM)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+8 IF $GET(^TMP("SCARRAY","S1"))'="""ALL"""
Begin DoDot:1
+9 SET (S1,S2,S3,S4,S5,S6,S7)=""
SET CT=0
SET C=0
+10 IF CC="SORT1"
Begin DoDot:2
+11 SET S1=""
FOR
SET S1=$ORDER(^TMP("SCRESULT",S1))
if S1=""
QUIT
Begin DoDot:3
+12 SET C=""
FOR
SET C=$ORDER(^TMP("SCRESULT",S1,C))
if C=""
QUIT
Begin DoDot:4
+13 SET CT=CT+1
SET ^TMP("SCRESULT",CT)=^TMP("SCRESULT",S1,C)
+14 KILL ^TMP("SCRESULT",S1,C)
End DoDot:4
End DoDot:3
End DoDot:2
+15 IF CC="SORT2"
Begin DoDot:2
+16 SET S1=""
FOR
SET S1=$ORDER(^TMP("SCRESULT",S1))
if S1=""
QUIT
Begin DoDot:3
+17 SET S2=""
FOR
SET S2=$ORDER(^TMP("SCRESULT",S1,S2))
if S2=""
QUIT
Begin DoDot:4
+18 SET C=""
FOR
SET C=$ORDER(^TMP("SCRESULT",S1,S2,C))
if C=""
QUIT
Begin DoDot:5
+19 SET CT=CT+1
SET ^TMP("SCRESULT",CT)=^TMP("SCRESULT",S1,S2,C)
+20 KILL ^TMP("SCRESULT",S1,S2,C)
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
+21 IF CC="SORT3"
Begin DoDot:2
+22 SET S1=""
FOR
SET S1=$ORDER(^TMP("SCRESULT",S1))
if S1=""
QUIT
Begin DoDot:3
+23 SET S2=""
FOR
SET S2=$ORDER(^TMP("SCRESULT",S1,S2))
if S2=""
QUIT
Begin DoDot:4
+24 SET S3=""
FOR
SET S3=$ORDER(^TMP("SCRESULT",S1,S2,S3))
if S3=""
QUIT
Begin DoDot:5
+25 SET C=""
FOR
SET C=$ORDER(^TMP("SCRESULT",S1,S2,S3,C))
if C=""
QUIT
Begin DoDot:6
+26 SET CT=CT+1
SET ^TMP("SCRESULT",CT)=^TMP("SCRESULT",S1,S2,S3,C)
+27 KILL ^TMP("SCRESULT",S1,S2,S3,C)
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
+28 IF CC="SORT4"
Begin DoDot:2
+29 SET S1=""
FOR
SET S1=$ORDER(^TMP("SCRESULT",S1))
if S1=""
QUIT
Begin DoDot:3
+30 SET S2=""
FOR
SET S2=$ORDER(^TMP("SCRESULT",S1,S2))
if S2=""
QUIT
Begin DoDot:4
+31 SET S3=""
FOR
SET S3=$ORDER(^TMP("SCRESULT",S1,S2,S3))
if S3=""
QUIT
Begin DoDot:5
+32 SET S4=""
FOR
SET S4=$ORDER(^TMP("SCRESULT",S1,S2,S3,S4))
if S4=""
QUIT
Begin DoDot:6
+33 SET C=""
FOR
SET C=$ORDER(^TMP("SCRESULT",S1,S2,S3,S4,C))
if C=""
QUIT
Begin DoDot:7
+34 SET CT=CT+1
SET ^TMP("SCRESULT",CT)=^TMP("SCRESULT",S1,S2,S3,S4,C)
+35 KILL ^TMP("SCRESULT",S1,S2,S3,S4,C)
End DoDot:7
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
+36 IF CC="SORT5"
Begin DoDot:2
+37 SET S1=""
FOR
SET S1=$ORDER(^TMP("SCRESULT",S1))
if S1=""
QUIT
Begin DoDot:3
+38 SET S2=""
FOR
SET S2=$ORDER(^TMP("SCRESULT",S1,S2))
if S2=""
QUIT
Begin DoDot:4
+39 SET S3=""
FOR
SET S3=$ORDER(^TMP("SCRESULT",S1,S2,S3))
if S3=""
QUIT
Begin DoDot:5
+40 SET S4=""
FOR
SET S4=$ORDER(^TMP("SCRESULT",S1,S2,S3,S4))
if S4=""
QUIT
Begin DoDot:6
+41 SET S5=""
FOR
SET S5=$ORDER(^TMP("SCRESULT",S1,S2,S3,S4,S5))
if S5=""
QUIT
Begin DoDot:7
+42 SET C=""
FOR
SET C=$ORDER(^TMP("SCRESULT",S1,S2,S3,S4,S5,C))
if C=""
QUIT
Begin DoDot:8
+43 SET CT=CT+1
SET ^TMP("SCRESULT",CT)=^TMP("SCRESULT",S1,S2,S3,S4,S5,C)
+44 KILL ^TMP("SCRESULT",S1,S2,S3,S4,S5,C)
End DoDot:8
End DoDot:7
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
+45 IF CC="SORT6"
Begin DoDot:2
+46 SET S1=""
FOR
SET S1=$ORDER(^TMP("SCRESULT",S1))
if S1=""
QUIT
Begin DoDot:3
+47 SET S2=""
FOR
SET S2=$ORDER(^TMP("SCRESULT",S1,S2))
if S2=""
QUIT
Begin DoDot:4
+48 SET S3=""
FOR
SET S3=$ORDER(^TMP("SCRESULT",S1,S2,S3))
if S3=""
QUIT
Begin DoDot:5
+49 SET S4=""
FOR
SET S4=$ORDER(^TMP("SCRESULT",S1,S2,S3,S4))
if S4=""
QUIT
Begin DoDot:6
+50 SET S5=""
FOR
SET S5=$ORDER(^TMP("SCRESULT",S1,S2,S3,S4,S5))
if S5=""
QUIT
Begin DoDot:7
+51 SET S6=""
FOR
SET S6=$ORDER(^TMP("SCRESULT",S1,S2,S3,S4,S5,S6))
if S6=""
QUIT
Begin DoDot:8
+52 SET C=""
FOR
SET C=$ORDER(^TMP("SCRESULT",S1,S2,S3,S4,S5,S6,C))
if C=""
QUIT
Begin DoDot:9
+53 SET CT=CT+1
SET ^TMP("SCRESULT",CT)=^TMP("SCRESULT",S1,S2,S3,S4,S5,S6,C)
+54 KILL ^TMP("SCRESULT",S1,S2,S3,S4,S5,S6,C)
End DoDot:9
End DoDot:8
End DoDot:7
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
+55 IF CC="SORT7"
Begin DoDot:2
+56 SET S1=""
FOR
SET S1=$ORDER(^TMP("SCRESULT",S1))
if S1=""
QUIT
Begin DoDot:3
+57 SET S2=""
FOR
SET S2=$ORDER(^TMP("SCRESULT",S1,S2))
if S2=""
QUIT
Begin DoDot:4
+58 SET S3=""
FOR
SET S3=$ORDER(^TMP("SCRESULT",S1,S2,S3))
if S3=""
QUIT
Begin DoDot:5
+59 SET S4=""
FOR
SET S4=$ORDER(^TMP("SCRESULT",S1,S2,S3,S4))
if S4=""
QUIT
Begin DoDot:6
+60 SET S5=""
FOR
SET S5=$ORDER(^TMP("SCRESULT",S1,S2,S3,S4,S5))
if S5=""
QUIT
Begin DoDot:7
+61 SET S6=""
FOR
SET S6=$ORDER(^TMP("SCRESULT",S1,S2,S3,S4,S5,S6))
if S6=""
QUIT
Begin DoDot:8
+62 SET S7=""
FOR
SET S7=$ORDER(^TMP("SCRESULT",S1,S2,S3,S4,S5,S6,S7))
if S7=""
QUIT
Begin DoDot:9
+63 SET C=""
FOR
SET C=$ORDER(^TMP("SCRESULT",S1,S2,S3,S4,S5,S6,S7,C))
if C=""
QUIT
Begin DoDot:10
+64 SET CT=CT+1
SET ^TMP("SCRESULT",CT)=^TMP("SCRESULT",S1,S2,S3,S4,S5,S6,S7,C)
+65 KILL ^TMP("SCRESULT",S1,S2,S3,S4,S5,S6,S7,C)
End DoDot:10
End DoDot:9
End DoDot:8
End DoDot:7
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+66 QUIT
EXIT ;
+1 KILL STAT,TN,TPN,IEN,INST,INSTN,UNDATE,UNREA,TEAMPN,SSN,SSNN,S1,S2,S3,S4,S5,S6,S7,S8
+2 KILL TEAM,TEAMN,TEAMP,PROVN,PROV,BDATE,EDATE,PAT,INAME,HOLD,NUM,NU,CC,C,CT,XX,ST
+3 KILL TN2,TPN2,UNDATE2,DATE2,EFFD,ERROR,SORT,SN,PDATE,POS,PREC,JJ,J,INUM,NN,P1,P2,P3
+4 KILL ^TMP("SCARRAY")
+5 QUIT
