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 Dec 13, 2024@02:30:07 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
