- PSS51P1B ;BIR/LDT - API FOR INFORMATION FROM FILE 51.1 CONT.; 5 Sep 03
- ;;1.0;PHARMACY DATA MANAGEMENT;**85,91,118**;9/30/97;Build 8
- ;
- SETZRO ;
- S ^TMP($J,LIST,+PSS(1),.01)=$G(PSS51P1(51.1,PSS(1),.01,"I"))
- S ^TMP($J,LIST,"B",$G(PSS51P1(51.1,PSS(1),.01,"I")),+PSS(1))=""
- S ^TMP($J,LIST,+PSS(1),1)=$G(PSS51P1(51.1,PSS(1),1,"I"))
- S ^TMP($J,LIST,+PSS(1),2)=$G(PSS51P1(51.1,PSS(1),2,"I"))
- S ^TMP($J,LIST,+PSS(1),4)=$G(PSS51P1(51.1,PSS(1),4,"I"))
- S ^TMP($J,LIST,+PSS(1),5)=$S($G(PSS51P1(51.1,PSS(1),5,"I"))="":"",1:PSS51P1(51.1,PSS(1),5,"I")_"^"_PSS51P1(51.1,PSS(1),5,"E"))
- S ^TMP($J,LIST,+PSS(1),6)=$G(PSS51P1(51.1,PSS(1),6,"I"))
- S ^TMP($J,LIST,+PSS(1),2.5)=$G(PSS51P1(51.1,PSS(1),2.5,"I"))
- S ^TMP($J,LIST,+PSS(1),8)=$G(PSS51P1(51.1,PSS(1),8,"I"))
- S ^TMP($J,LIST,+PSS(1),8.1)=$G(PSS51P1(51.1,PSS(1),8.1,"I"))
- Q
- ;
- SETWARD ;
- S ^TMP($J,LIST,+PSS(1),"WARD",+PSS(2),.01)=$S($G(^TMP($J,"PSS51P1",51.11,PSS(2),.01,"I"))="":"",1:^TMP($J,"PSS51P1",51.11,PSS(2),.01,"I")_"^"_^TMP($J,"PSS51P1",51.11,PSS(2),.01,"E"))
- S ^TMP($J,LIST,+PSS(1),"WARD",+PSS(2),1)=$G(^TMP($J,"PSS51P1",51.11,PSS(2),1,"I"))
- Q
- ;
- SETLOC ;
- S ^TMP($J,LIST,+PSSIEN,"HOSP",+PSS(1),.01)=$S($G(^TMP($J,"PSS51P1",51.17,PSS(1),.01,"I"))="":"",1:^TMP($J,"PSS51P1",51.17,PSS(1),.01,"I")_"^"_^TMP($J,"PSS51P1",51.17,PSS(1),.01,"E"))
- S ^TMP($J,LIST,+PSSIEN,"HOSP",+PSS(1),1)=$G(^TMP($J,"PSS51P1",51.17,PSS(1),1,"I"))
- S ^TMP($J,LIST,+PSSIEN,"HOSP",+PSS(1),2)=$G(^TMP($J,"PSS51P1",51.17,PSS(1),2,"I"))
- Q
- ;
- LOOP(PSSLP) ;
- N CNT,CNT1,PSS S (CNT,PSS(3))=0
- F S PSS(3)=$O(^PS(51.1,PSS(3))) Q:'PSS(3) D @(PSSLP)
- S ^TMP($J,LIST,0)=$S(CNT>0:CNT,1:"-1^NO DATA FOUND")
- K ^TMP("DILIST",$J)
- Q
- ;
- SETWRD2 ;
- S ^TMP($J,LIST,+PSSIEN,"WARD",+PSS(2),.01)=$S($G(^TMP($J,"PSS51P1",51.11,PSS(2),.01,"I"))="":"",1:^TMP($J,"PSS51P1",51.11,PSS(2),.01,"I")_"^"_^TMP($J,"PSS51P1",51.11,PSS(2),.01,"E"))
- S ^TMP($J,LIST,+PSSIEN,"WARD",+PSS(2),1)=$G(^TMP($J,"PSS51P1",51.11,PSS(2),1,"I"))
- S ^TMP($J,LIST,+PSSIEN,"WARD",0)=1
- Q
- ;
- 1 ;
- I $G(PSSTSCH)]"" Q:$P($G(^PS(51.1,PSS(3),0)),"^",5)'="O"
- I $G(PSSPP)]"" Q:$P($G(^PS(51.1,PSS(3),0)),"^",4)'=PSSPP
- S PSSIEN=PSS(3) K PSS51P1 D GETS^DIQ(51.1,+PSSIEN,".01;1;2;4;5;6;2.5;8;8.1","IE","PSS51P1") S PSS(1)=0
- F S PSS(1)=$O(PSS51P1(51.1,PSS(1))) Q:'PSS(1) D SETZRO S CNT=CNT+1
- K PSS51P1
- Q
- ;
- 2 ;
- S PSSIEN=PSS(3) K ^TMP($J,"PSS51P1")
- I +$G(PSSIEN2)'>0 D GETS^DIQ(51.1,+PSSIEN,".01;3*","IE","^TMP($J,""PSS51P1""") S PSS(1)=0 D
- .F S PSS(1)=$O(^TMP($J,"PSS51P1",51.1,PSS(1))) Q:'PSS(1) D
- ..S ^TMP($J,LIST,+PSS(1),.01)=$G(^TMP($J,"PSS51P1",51.1,PSS(1),.01,"I")),CNT=CNT+1
- ..S ^TMP($J,LIST,"B",$G(^TMP($J,"PSS51P1",51.1,PSS(1),.01,"E")),+PSS(1))="" S (PSS(2),CNT1)=0 D
- ...F S PSS(2)=$O(^TMP($J,"PSS51P1",51.11,PSS(2))) Q:'PSS(2) D SETWARD S CNT1=CNT1+1
- ...S ^TMP($J,LIST,+PSS(1),"WARD",0)=$S(CNT1>0:CNT1,1:"-1^NO DATA FOUND")
- I +$G(PSSIEN2)>0 D GETS^DIQ(51.1,+PSSIEN,".01","IE","^TMP($J,""PSS51P1""") D
- .S PSS(4)=0 F S PSS(4)=$O(^TMP($J,"PSS51P1",51.1,PSS(4))) Q:'PSS(4) D
- ..S ^TMP($J,LIST,+PSS(4),.01)=$G(^TMP($J,"PSS51P1",51.1,PSS(4),.01,"I")),CNT=CNT+1
- ..S ^TMP($J,LIST,"B",$G(^TMP($J,"PSS51P1",51.1,PSS(4),.01,"E")),+PSS(4))=""
- ..D GETS^DIQ(51.11,+PSSIEN2_","_+PSSIEN,".01;1","IE","^TMP($J,""PSS51P1""")
- ..S PSS(1)=+PSSIEN,(PSS(2),CNT1)=0 F S PSS(2)=$O(^TMP($J,"PSS51P1",51.11,PSS(2))) Q:'PSS(2) D SETWARD^PSS51P1B S CNT1=CNT1+1
- ..S ^TMP($J,LIST,+PSSIEN,"WARD",0)=$S(CNT1>0:CNT1,1:"-1^NO DATA FOUND FOR PSSIEN2 #"_PSSIEN2)
- K ^TMP($J,"PSS51P1")
- Q
- 3 ;
- S PSSIEN=PSS(3) K ^TMP($J,"PSS51P1") D GETS^DIQ(51.1,+PSSIEN,".01;7*","IE","^TMP($J,""PSS51P1""") S (PSS(1),CNT1)=0 D
- .F S PSS(1)=$O(^TMP($J,"PSS51P1",51.17,PSS(1))) Q:'PSS(1) D SETLOC S CNT1=CNT1+1
- .S ^TMP($J,LIST,+PSSIEN,"HOSP",0)=$S(CNT1>0:CNT1,1:"-1^NO DATA FOUND")
- .S PSS(2)=0 F S PSS(2)=$O(^TMP($J,"PSS51P1",51.1,PSS(2))) Q:'PSS(2) D
- ..S ^TMP($J,LIST,+PSS(2),.01)=$G(^TMP($J,"PSS51P1",51.1,PSS(2),.01,"I")),CNT=CNT+1
- ..S ^TMP($J,LIST,"B",$G(^TMP($J,"PSS51P1",51.1,PSS(2),.01,"E")),+PSS(2))=""
- K ^TMP($J,"PSS51P1")
- Q
- 4 ;
- S PSSIEN=PSS(3)
- D GETS^DIQ(51.1,+PSSIEN,".01;1","IE","PSS51P1")
- N PSSXX S PSSXX=0 F S PSSXX=$O(PSS51P1(51.1,PSSXX)) Q:'PSSXX D
- .S ^TMP($J,LIST,+PSSXX,.01)=$G(PSS51P1(51.1,PSSXX,.01,"E")),CNT=CNT+1
- .S ^TMP($J,LIST,"B",$G(PSS51P1(51.1,PSSXX,.01,"E")),+PSSXX)=""
- .S ^TMP($J,LIST,+PSSXX,1)=$G(PSS51P1(51.1,PSSXX,1,"E"))
- K PSS51P1
- Q
- 5 ;
- I $G(PSSPP)]"",$P($G(^PS(51.1,+PSS(3),0)),"^",4)'=$G(PSSPP) Q
- I $G(PSSTYP)]"",$P($G(^PS(51.1,+PSS(3),0)),"^",5)'[PSSTYP Q
- D FIND^DIC(51.1,,"@;.01;1;2;2.5;4;5IE;8","Q","`"_PSS(3),,,,"")
- N PSSXX S PSSXX=0 F S PSSXX=$O(^TMP("DILIST",$J,"ID",PSSXX)) Q:'PSSXX D
- .S PSSIEN=+PSS(3)
- .I $$FREQ^PSS51P1(+$G(^TMP("DILIST",$J,"ID",PSSXX,2)),PSSFREQ) Q
- .S CNT=CNT+1
- .S ^TMP($J,LIST,+PSSIEN,.01)=$G(^TMP("DILIST",$J,"ID",PSSXX,.01))
- .S ^TMP($J,LIST,"AP"_PSSPP,$G(^TMP("DILIST",$J,"ID",PSSXX,.01)),+PSSIEN)=""
- .S ^TMP($J,LIST,+PSSIEN,1)=$G(^TMP("DILIST",$J,"ID",PSSXX,1))
- .S ^TMP($J,LIST,+PSSIEN,2)=$G(^TMP("DILIST",$J,"ID",PSSXX,2))
- .S ^TMP($J,LIST,+PSSIEN,2.5)=$G(^TMP("DILIST",$J,"ID",PSSXX,2.5))
- .S ^TMP($J,LIST,+PSSIEN,4)=$G(^TMP("DILIST",$J,"ID",PSSXX,4))
- .S ^TMP($J,LIST,+PSSIEN,5)=$S($G(^TMP("DILIST",$J,"ID",PSSXX,5,"I"))="":"",1:$G(^TMP("DILIST",$J,"ID",PSSXX,5,"I"))_"^"_$G(^TMP("DILIST",$J,"ID",PSSXX,5,"E")))
- .S ^TMP($J,LIST,+PSSIEN,8)=$G(^TMP("DILIST",$J,"ID",PSSXX,8))
- .D HOSPLOC^PSS51P1A(LIST,+PSSIEN)
- .I +$G(PSSWDIEN)'>0 K ^TMP($J,"PSS51P1") D GETS^DIQ(51.1,+PSSIEN,".01;3*","IE","^TMP($J,""PSS51P1""") D
- ..S PSS(1)=+PSSIEN,(PSS(2),CNT1)=0 F S PSS(2)=$O(^TMP($J,"PSS51P1",51.11,PSS(2))) Q:'PSS(2) D SETWARD^PSS51P1B S CNT1=CNT1+1
- ..S ^TMP($J,LIST,+PSSIEN,"WARD",0)=$S(CNT1>0:CNT1,1:-1_"^"_"NO DATA FOUND")
- .I +$G(PSSWDIEN)>0 K ^TMP($J,"PSS51P1") D GETS^DIQ(51.1,+PSSIEN,".01;3*","IE","^TMP($J,""PSS51P1""") D
- ..S (PSS(2),CNT1)=0 F S PSS(2)=$O(^TMP($J,"PSS51P1",51.11,PSS(2))) Q:'PSS(2) D
- ...I PSSWDIEN=$P($G(^TMP($J,"PSS51P1",51.11,PSS(2),.01,"I")),"^") D SETWRD2^PSS51P1B S CNT1=CNT1+1
- ..S ^TMP($J,LIST,+PSSIEN,"WARD",0)=$S(CNT1>0:CNT1,1:"-1^NO DATA FOUND FOR PSSWDIEN #"_PSSWDIEN)
- K ^TMP("DILIST",$J),^TMP($J,"PSS51P1")
- Q
- ;
- 6 ;
- I $G(PSSPP)]"",$P($G(^PS(51.1,+PSS(3),0)),"^",4)'=PSSPP Q
- K PSS51P1 D GETS^DIQ(51.1,+PSS(3),".01;1;2;2.5;4;5;6;8;8.1","IE","PSS51P1")
- N PSSXX S PSSXX=0 F S PSSXX=$O(PSS51P1(51.1,PSSXX)) Q:'PSSXX D
- .S ^TMP($J,LIST,+PSSXX,.01)=$G(PSS51P1(51.1,PSSXX,.01,"E")),CNT=CNT+1
- .S ^TMP($J,LIST,"AP"_PSSPP,$G(PSS51P1(51.1,PSSXX,.01,"E")),+PSSXX)=""
- .S ^TMP($J,LIST,+PSSXX,1)=$G(PSS51P1(51.1,PSSXX,1,"E"))
- .S ^TMP($J,LIST,+PSSXX,2)=$G(PSS51P1(51.1,PSSXX,2,"E"))
- .S ^TMP($J,LIST,+PSSXX,2.5)=$G(PSS51P1(51.1,PSSXX,2.5,"E"))
- .S ^TMP($J,LIST,+PSSXX,4)=$G(PSS51P1(51.1,PSSXX,4,"E"))
- .S ^TMP($J,LIST,+PSSXX,5)=$S($G(PSS51P1(51.1,PSSXX,5,"I"))]"":$G(PSS51P1(51.1,PSSXX,5,"I"))_"^"_$G(PSS51P1(51.1,PSSXX,5,"E")),1:"")
- .S ^TMP($J,LIST,+PSSXX,6)=$G(PSS51P1(51.1,PSSXX,6,"E"))
- .S ^TMP($J,LIST,+PSSXX,8)=$G(PSS51P1(51.1,PSSXX,8,"E"))
- .S ^TMP($J,LIST,+PSSXX,8.1)=$G(PSS51P1(51.1,PSSXX,8.1,"E"))
- K PSS51P1
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSS51P1B 7134 printed Feb 18, 2025@23:56:09 Page 2
- PSS51P1B ;BIR/LDT - API FOR INFORMATION FROM FILE 51.1 CONT.; 5 Sep 03
- +1 ;;1.0;PHARMACY DATA MANAGEMENT;**85,91,118**;9/30/97;Build 8
- +2 ;
- SETZRO ;
- +1 SET ^TMP($JOB,LIST,+PSS(1),.01)=$GET(PSS51P1(51.1,PSS(1),.01,"I"))
- +2 SET ^TMP($JOB,LIST,"B",$GET(PSS51P1(51.1,PSS(1),.01,"I")),+PSS(1))=""
- +3 SET ^TMP($JOB,LIST,+PSS(1),1)=$GET(PSS51P1(51.1,PSS(1),1,"I"))
- +4 SET ^TMP($JOB,LIST,+PSS(1),2)=$GET(PSS51P1(51.1,PSS(1),2,"I"))
- +5 SET ^TMP($JOB,LIST,+PSS(1),4)=$GET(PSS51P1(51.1,PSS(1),4,"I"))
- +6 SET ^TMP($JOB,LIST,+PSS(1),5)=$SELECT($GET(PSS51P1(51.1,PSS(1),5,"I"))="":"",1:PSS51P1(51.1,PSS(1),5,"I")_"^"_PSS51P1(51.1,PSS(1),5,"E"))
- +7 SET ^TMP($JOB,LIST,+PSS(1),6)=$GET(PSS51P1(51.1,PSS(1),6,"I"))
- +8 SET ^TMP($JOB,LIST,+PSS(1),2.5)=$GET(PSS51P1(51.1,PSS(1),2.5,"I"))
- +9 SET ^TMP($JOB,LIST,+PSS(1),8)=$GET(PSS51P1(51.1,PSS(1),8,"I"))
- +10 SET ^TMP($JOB,LIST,+PSS(1),8.1)=$GET(PSS51P1(51.1,PSS(1),8.1,"I"))
- +11 QUIT
- +12 ;
- SETWARD ;
- +1 SET ^TMP($JOB,LIST,+PSS(1),"WARD",+PSS(2),.01)=$SELECT($GET(^TMP($JOB,"PSS51P1",51.11,PSS(2),.01,"I"))="":"",1:^TMP($JOB,"PSS51P1",51.11,PSS(2),.01,"I")_"^"_^TMP($JOB,"PSS51P1",51.11,PSS(2),.01,"E"))
- +2 SET ^TMP($JOB,LIST,+PSS(1),"WARD",+PSS(2),1)=$GET(^TMP($JOB,"PSS51P1",51.11,PSS(2),1,"I"))
- +3 QUIT
- +4 ;
- SETLOC ;
- +1 SET ^TMP($JOB,LIST,+PSSIEN,"HOSP",+PSS(1),.01)=$SELECT($GET(^TMP($JOB,"PSS51P1",51.17,PSS(1),.01,"I"))="":"",1:^TMP($JOB,"PSS51P1",51.17,PSS(1),.01,"I")_"^"_^TMP($JOB,"PSS51P1",51.17,PSS(1),.01,"E"))
- +2 SET ^TMP($JOB,LIST,+PSSIEN,"HOSP",+PSS(1),1)=$GET(^TMP($JOB,"PSS51P1",51.17,PSS(1),1,"I"))
- +3 SET ^TMP($JOB,LIST,+PSSIEN,"HOSP",+PSS(1),2)=$GET(^TMP($JOB,"PSS51P1",51.17,PSS(1),2,"I"))
- +4 QUIT
- +5 ;
- LOOP(PSSLP) ;
- +1 NEW CNT,CNT1,PSS
- SET (CNT,PSS(3))=0
- +2 FOR
- SET PSS(3)=$ORDER(^PS(51.1,PSS(3)))
- if 'PSS(3)
- QUIT
- DO @(PSSLP)
- +3 SET ^TMP($JOB,LIST,0)=$SELECT(CNT>0:CNT,1:"-1^NO DATA FOUND")
- +4 KILL ^TMP("DILIST",$JOB)
- +5 QUIT
- +6 ;
- SETWRD2 ;
- +1 SET ^TMP($JOB,LIST,+PSSIEN,"WARD",+PSS(2),.01)=$SELECT($GET(^TMP($JOB,"PSS51P1",51.11,PSS(2),.01,"I"))="":"",1:^TMP($JOB,"PSS51P1",51.11,PSS(2),.01,"I")_"^"_^TMP($JOB,"PSS51P1",51.11,PSS(2),.01,"E"))
- +2 SET ^TMP($JOB,LIST,+PSSIEN,"WARD",+PSS(2),1)=$GET(^TMP($JOB,"PSS51P1",51.11,PSS(2),1,"I"))
- +3 SET ^TMP($JOB,LIST,+PSSIEN,"WARD",0)=1
- +4 QUIT
- +5 ;
- 1 ;
- +1 IF $GET(PSSTSCH)]""
- if $PIECE($GET(^PS(51.1,PSS(3),0)),"^",5)'="O"
- QUIT
- +2 IF $GET(PSSPP)]""
- if $PIECE($GET(^PS(51.1,PSS(3),0)),"^",4)'=PSSPP
- QUIT
- +3 SET PSSIEN=PSS(3)
- KILL PSS51P1
- DO GETS^DIQ(51.1,+PSSIEN,".01;1;2;4;5;6;2.5;8;8.1","IE","PSS51P1")
- SET PSS(1)=0
- +4 FOR
- SET PSS(1)=$ORDER(PSS51P1(51.1,PSS(1)))
- if 'PSS(1)
- QUIT
- DO SETZRO
- SET CNT=CNT+1
- +5 KILL PSS51P1
- +6 QUIT
- +7 ;
- 2 ;
- +1 SET PSSIEN=PSS(3)
- KILL ^TMP($JOB,"PSS51P1")
- +2 IF +$GET(PSSIEN2)'>0
- DO GETS^DIQ(51.1,+PSSIEN,".01;3*","IE","^TMP($J,""PSS51P1""")
- SET PSS(1)=0
- Begin DoDot:1
- +3 FOR
- SET PSS(1)=$ORDER(^TMP($JOB,"PSS51P1",51.1,PSS(1)))
- if 'PSS(1)
- QUIT
- Begin DoDot:2
- +4 SET ^TMP($JOB,LIST,+PSS(1),.01)=$GET(^TMP($JOB,"PSS51P1",51.1,PSS(1),.01,"I"))
- SET CNT=CNT+1
- +5 SET ^TMP($JOB,LIST,"B",$GET(^TMP($JOB,"PSS51P1",51.1,PSS(1),.01,"E")),+PSS(1))=""
- SET (PSS(2),CNT1)=0
- Begin DoDot:3
- +6 FOR
- SET PSS(2)=$ORDER(^TMP($JOB,"PSS51P1",51.11,PSS(2)))
- if 'PSS(2)
- QUIT
- DO SETWARD
- SET CNT1=CNT1+1
- +7 SET ^TMP($JOB,LIST,+PSS(1),"WARD",0)=$SELECT(CNT1>0:CNT1,1:"-1^NO DATA FOUND")
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +8 IF +$GET(PSSIEN2)>0
- DO GETS^DIQ(51.1,+PSSIEN,".01","IE","^TMP($J,""PSS51P1""")
- Begin DoDot:1
- +9 SET PSS(4)=0
- FOR
- SET PSS(4)=$ORDER(^TMP($JOB,"PSS51P1",51.1,PSS(4)))
- if 'PSS(4)
- QUIT
- Begin DoDot:2
- +10 SET ^TMP($JOB,LIST,+PSS(4),.01)=$GET(^TMP($JOB,"PSS51P1",51.1,PSS(4),.01,"I"))
- SET CNT=CNT+1
- +11 SET ^TMP($JOB,LIST,"B",$GET(^TMP($JOB,"PSS51P1",51.1,PSS(4),.01,"E")),+PSS(4))=""
- +12 DO GETS^DIQ(51.11,+PSSIEN2_","_+PSSIEN,".01;1","IE","^TMP($J,""PSS51P1""")
- +13 SET PSS(1)=+PSSIEN
- SET (PSS(2),CNT1)=0
- FOR
- SET PSS(2)=$ORDER(^TMP($JOB,"PSS51P1",51.11,PSS(2)))
- if 'PSS(2)
- QUIT
- DO SETWARD^PSS51P1B
- SET CNT1=CNT1+1
- +14 SET ^TMP($JOB,LIST,+PSSIEN,"WARD",0)=$SELECT(CNT1>0:CNT1,1:"-1^NO DATA FOUND FOR PSSIEN2 #"_PSSIEN2)
- End DoDot:2
- End DoDot:1
- +15 KILL ^TMP($JOB,"PSS51P1")
- +16 QUIT
- 3 ;
- +1 SET PSSIEN=PSS(3)
- KILL ^TMP($JOB,"PSS51P1")
- DO GETS^DIQ(51.1,+PSSIEN,".01;7*","IE","^TMP($J,""PSS51P1""")
- SET (PSS(1),CNT1)=0
- Begin DoDot:1
- +2 FOR
- SET PSS(1)=$ORDER(^TMP($JOB,"PSS51P1",51.17,PSS(1)))
- if 'PSS(1)
- QUIT
- DO SETLOC
- SET CNT1=CNT1+1
- +3 SET ^TMP($JOB,LIST,+PSSIEN,"HOSP",0)=$SELECT(CNT1>0:CNT1,1:"-1^NO DATA FOUND")
- +4 SET PSS(2)=0
- FOR
- SET PSS(2)=$ORDER(^TMP($JOB,"PSS51P1",51.1,PSS(2)))
- if 'PSS(2)
- QUIT
- Begin DoDot:2
- +5 SET ^TMP($JOB,LIST,+PSS(2),.01)=$GET(^TMP($JOB,"PSS51P1",51.1,PSS(2),.01,"I"))
- SET CNT=CNT+1
- +6 SET ^TMP($JOB,LIST,"B",$GET(^TMP($JOB,"PSS51P1",51.1,PSS(2),.01,"E")),+PSS(2))=""
- End DoDot:2
- End DoDot:1
- +7 KILL ^TMP($JOB,"PSS51P1")
- +8 QUIT
- 4 ;
- +1 SET PSSIEN=PSS(3)
- +2 DO GETS^DIQ(51.1,+PSSIEN,".01;1","IE","PSS51P1")
- +3 NEW PSSXX
- SET PSSXX=0
- FOR
- SET PSSXX=$ORDER(PSS51P1(51.1,PSSXX))
- if 'PSSXX
- QUIT
- Begin DoDot:1
- +4 SET ^TMP($JOB,LIST,+PSSXX,.01)=$GET(PSS51P1(51.1,PSSXX,.01,"E"))
- SET CNT=CNT+1
- +5 SET ^TMP($JOB,LIST,"B",$GET(PSS51P1(51.1,PSSXX,.01,"E")),+PSSXX)=""
- +6 SET ^TMP($JOB,LIST,+PSSXX,1)=$GET(PSS51P1(51.1,PSSXX,1,"E"))
- End DoDot:1
- +7 KILL PSS51P1
- +8 QUIT
- 5 ;
- +1 IF $GET(PSSPP)]""
- IF $PIECE($GET(^PS(51.1,+PSS(3),0)),"^",4)'=$GET(PSSPP)
- QUIT
- +2 IF $GET(PSSTYP)]""
- IF $PIECE($GET(^PS(51.1,+PSS(3),0)),"^",5)'[PSSTYP
- QUIT
- +3 DO FIND^DIC(51.1,,"@;.01;1;2;2.5;4;5IE;8","Q","`"_PSS(3),,,,"")
- +4 NEW PSSXX
- SET PSSXX=0
- FOR
- SET PSSXX=$ORDER(^TMP("DILIST",$JOB,"ID",PSSXX))
- if 'PSSXX
- QUIT
- Begin DoDot:1
- +5 SET PSSIEN=+PSS(3)
- +6 IF $$FREQ^PSS51P1(+$GET(^TMP("DILIST",$JOB,"ID",PSSXX,2)),PSSFREQ)
- QUIT
- +7 SET CNT=CNT+1
- +8 SET ^TMP($JOB,LIST,+PSSIEN,.01)=$GET(^TMP("DILIST",$JOB,"ID",PSSXX,.01))
- +9 SET ^TMP($JOB,LIST,"AP"_PSSPP,$GET(^TMP("DILIST",$JOB,"ID",PSSXX,.01)),+PSSIEN)=""
- +10 SET ^TMP($JOB,LIST,+PSSIEN,1)=$GET(^TMP("DILIST",$JOB,"ID",PSSXX,1))
- +11 SET ^TMP($JOB,LIST,+PSSIEN,2)=$GET(^TMP("DILIST",$JOB,"ID",PSSXX,2))
- +12 SET ^TMP($JOB,LIST,+PSSIEN,2.5)=$GET(^TMP("DILIST",$JOB,"ID",PSSXX,2.5))
- +13 SET ^TMP($JOB,LIST,+PSSIEN,4)=$GET(^TMP("DILIST",$JOB,"ID",PSSXX,4))
- +14 SET ^TMP($JOB,LIST,+PSSIEN,5)=$SELECT($GET(^TMP("DILIST",$JOB,"ID",PSSXX,5,"I"))="":"",1:$GET(^TMP("DILIST",$JOB,"ID",PSSXX,5,"I"))_"^"_$GET(^TMP("DILIST",$JOB,"ID",PSSXX,5,"E")))
- +15 SET ^TMP($JOB,LIST,+PSSIEN,8)=$GET(^TMP("DILIST",$JOB,"ID",PSSXX,8))
- +16 DO HOSPLOC^PSS51P1A(LIST,+PSSIEN)
- +17 IF +$GET(PSSWDIEN)'>0
- KILL ^TMP($JOB,"PSS51P1")
- DO GETS^DIQ(51.1,+PSSIEN,".01;3*","IE","^TMP($J,""PSS51P1""")
- Begin DoDot:2
- +18 SET PSS(1)=+PSSIEN
- SET (PSS(2),CNT1)=0
- FOR
- SET PSS(2)=$ORDER(^TMP($JOB,"PSS51P1",51.11,PSS(2)))
- if 'PSS(2)
- QUIT
- DO SETWARD^PSS51P1B
- SET CNT1=CNT1+1
- +19 SET ^TMP($JOB,LIST,+PSSIEN,"WARD",0)=$SELECT(CNT1>0:CNT1,1:-1_"^"_"NO DATA FOUND")
- End DoDot:2
- +20 IF +$GET(PSSWDIEN)>0
- KILL ^TMP($JOB,"PSS51P1")
- DO GETS^DIQ(51.1,+PSSIEN,".01;3*","IE","^TMP($J,""PSS51P1""")
- Begin DoDot:2
- +21 SET (PSS(2),CNT1)=0
- FOR
- SET PSS(2)=$ORDER(^TMP($JOB,"PSS51P1",51.11,PSS(2)))
- if 'PSS(2)
- QUIT
- Begin DoDot:3
- +22 IF PSSWDIEN=$PIECE($GET(^TMP($JOB,"PSS51P1",51.11,PSS(2),.01,"I")),"^")
- DO SETWRD2^PSS51P1B
- SET CNT1=CNT1+1
- End DoDot:3
- +23 SET ^TMP($JOB,LIST,+PSSIEN,"WARD",0)=$SELECT(CNT1>0:CNT1,1:"-1^NO DATA FOUND FOR PSSWDIEN #"_PSSWDIEN)
- End DoDot:2
- End DoDot:1
- +24 KILL ^TMP("DILIST",$JOB),^TMP($JOB,"PSS51P1")
- +25 QUIT
- +26 ;
- 6 ;
- +1 IF $GET(PSSPP)]""
- IF $PIECE($GET(^PS(51.1,+PSS(3),0)),"^",4)'=PSSPP
- QUIT
- +2 KILL PSS51P1
- DO GETS^DIQ(51.1,+PSS(3),".01;1;2;2.5;4;5;6;8;8.1","IE","PSS51P1")
- +3 NEW PSSXX
- SET PSSXX=0
- FOR
- SET PSSXX=$ORDER(PSS51P1(51.1,PSSXX))
- if 'PSSXX
- QUIT
- Begin DoDot:1
- +4 SET ^TMP($JOB,LIST,+PSSXX,.01)=$GET(PSS51P1(51.1,PSSXX,.01,"E"))
- SET CNT=CNT+1
- +5 SET ^TMP($JOB,LIST,"AP"_PSSPP,$GET(PSS51P1(51.1,PSSXX,.01,"E")),+PSSXX)=""
- +6 SET ^TMP($JOB,LIST,+PSSXX,1)=$GET(PSS51P1(51.1,PSSXX,1,"E"))
- +7 SET ^TMP($JOB,LIST,+PSSXX,2)=$GET(PSS51P1(51.1,PSSXX,2,"E"))
- +8 SET ^TMP($JOB,LIST,+PSSXX,2.5)=$GET(PSS51P1(51.1,PSSXX,2.5,"E"))
- +9 SET ^TMP($JOB,LIST,+PSSXX,4)=$GET(PSS51P1(51.1,PSSXX,4,"E"))
- +10 SET ^TMP($JOB,LIST,+PSSXX,5)=$SELECT($GET(PSS51P1(51.1,PSSXX,5,"I"))]"":$GET(PSS51P1(51.1,PSSXX,5,"I"))_"^"_$GET(PSS51P1(51.1,PSSXX,5,"E")),1:"")
- +11 SET ^TMP($JOB,LIST,+PSSXX,6)=$GET(PSS51P1(51.1,PSSXX,6,"E"))
- +12 SET ^TMP($JOB,LIST,+PSSXX,8)=$GET(PSS51P1(51.1,PSSXX,8,"E"))
- +13 SET ^TMP($JOB,LIST,+PSSXX,8.1)=$GET(PSS51P1(51.1,PSSXX,8.1,"E"))
- End DoDot:1
- +14 KILL PSS51P1
- +15 QUIT