- PSS50E ;BIR/LDT - API FOR INFORMATION FROM FILE 50; 5 Sep 03
- ;;1.0;PHARMACY DATA MANAGEMENT;**85,104**;9/30/97
- ;
- SKB(PSSIEN2,PSSFL2) ;
- ;PSSIEN2 - IEN of entry in 50
- ;PSSFL2 - action flag - S to set the "B" cross-reference or
- ; K to kill the "B" cross-reference.
- ;
- I +$G(PSSIEN2)'>0 Q 0
- I "SK"'[$G(PSSFL2) Q 0
- I PSSFL2="S",$G(^PSDRUG(+PSSIEN2,0))]"" S ^PSDRUG("B",$E($P($G(^PSDRUG(+PSSIEN2,0)),"^"),1,40),+PSSIEN2)="" Q 1
- I PSSFL2="K",$G(^PSDRUG(+PSSIEN2,0))]"" K ^PSDRUG("B",$E($P($G(^PSDRUG(+PSSIEN2,0)),"^"),1,40),+PSSIEN2) Q 1
- Q 0
- ;
- I $A(PSSVAL)'=34 S PSSVAL=$C(34)_PSSVAL_$C(34)
- AOC ;
- ;PSSVAL - VA CLASSIFICATION field (#2) of the DRUG file (#50)
- ;PSSFL - Inactive flag - "" - All entries
- ; FileMan Date - Only entries with no Inactive Date or an Inactive Date greater than this date.
- ;PSSPK - Application Package's Use - "" - All entries
- ; Alphabetic codes that represent the DHCP packages that consider this drug to be
- ; part of their formulary.
- ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is the Field Number of the data
- ; piece being returned.
- ;
- N PSS
- I $G(LIST)']"" Q
- K ^TMP($J,LIST)
- I $G(PSSVAL)']"" S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
- S ^TMP($J,LIST,0)=0
- S PSS(1)=0 F S PSS(1)=$O(^PSDRUG("AOC",PSS(1))) Q:'PSS(1) S PSS(2)="" F S PSS(2)=$O(^PSDRUG("AOC",PSS(1),PSS(2))) Q:PSS(2)="" D
- .Q:PSS(2)'=PSSVAL S PSS(3)=0 F S PSS(3)=$O(^PSDRUG("AOC",PSS(1),PSS(2),PSS(3))) Q:'PSS(3) D
- ..N ZNODE,NODE2,INODE S ZNODE=$G(^PSDRUG(+PSS(3),0)),NODE2=$G(^(2)),INODE=$G(^("I"))
- ..I +$G(PSSFL)>0,+INODE>0,+INODE'>PSSFL Q
- ..;Naked reference below refers to ^PSDRUG(+PSS(3),2)
- ..I $G(PSSPK)]"" N PSSZ5,PSSZ6 S PSSZ5=0 F PSSZ6=1:1:$L(PSSPK) Q:PSSZ5 I $P($G(^(2)),"^",3)[$E(PSSPK,PSSZ6) S PSSZ5=1
- ..I $G(PSSPK)]"",'PSSZ5 Q
- ..S ^TMP($J,LIST,0)=^TMP($J,LIST,0)+1,^TMP($J,LIST,+PSS(3),.01)=$P(ZNODE,"^")
- ..S ^TMP($J,LIST,"AOC",$P(ZNODE,"^"),+PSS(3))=""
- I ^TMP($J,LIST,0)'>0 S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND"
- Q
- ;
- C ;
- ;PSSVAL - SYNONYM sub-field (#9) of the DRUG file (#50)
- ;PSSFL - Inactive flag - "" - All entries
- ; FileMan Date - Only entries with no Inactive Date or an Inactive Date greater than this date.
- ;PSSPK - Application Package's Use - "" - All entries
- ; Alphabetic codes that represent the DHCP packages that consider this drug to be
- ; part of their formulary.
- ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is the Field Number of the data
- ; piece being returned.
- ;
- N DIERR,ZZERR,PSS,PSSP50
- I $G(LIST)']"" Q
- K ^TMP($J,LIST)
- I $G(PSSVAL)']"" S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
- S ^TMP($J,LIST,0)=0
- S PSS(1)="" F S PSS(1)=$O(^PSDRUG("C",PSS(1))) Q:PSS(1)="" S PSS(2)="" F S PSS(2)=$O(^PSDRUG("C",PSS(1),PSS(2))) Q:PSS(2)="" D
- .Q:PSS(1)'=PSSVAL D
- ..N ZNODE,NODE2,INODE S ZNODE=$G(^PSDRUG(+PSS(2),0)),NODE2=$G(^(2)),INODE=$P($G(^("I")),"^")
- ..I +$G(PSSFL)>0,+INODE>0,+INODE'>PSSFL Q
- ..;Naked reference below refers to ^PSDRUG(+PSS(2),2)
- ..I $G(PSSPK)]"" N PSSZ5,PSSZ6 S PSSZ5=0 F PSSZ6=1:1:$L(PSSPK) Q:PSSZ5 I $P($G(^(2)),"^",3)[$E(PSSPK,PSSZ6) S PSSZ5=1
- ..I $G(PSSPK)]"",'PSSZ5 Q
- ..S ^TMP($J,LIST,0)=^TMP($J,LIST,0)+1,^TMP($J,LIST,+PSS(2),.01)=$P(ZNODE,"^"),^TMP($J,LIST,"C",$P(ZNODE,"^"),+PSS(2))="" D
- ...K PSSP50 D GETS^DIQ(50,+PSS(2),"9*","IE","PSSP50") S PSS(3)=0
- ...F S PSS(3)=$O(PSSP50(50.1,PSS(3))) Q:'PSS(3) D
- ....S ^TMP($J,LIST,+PSS(2),+PSS(3),.01)=$G(PSSP50(50.1,PSS(3),.01,"I"))
- ....S ^TMP($J,LIST,+PSS(2),+PSS(3),2)=$G(PSSP50(50.1,PSS(3),2,"I"))
- ....S ^TMP($J,LIST,+PSS(2),+PSS(3),1)=$S($G(PSSP50(50.1,PSS(3),1,"I"))="":"",1:PSSP50(50.1,PSS(3),1,"I")_"^"_PSSP50(50.1,PSS(3),1,"E"))
- ....S ^TMP($J,LIST,+PSS(2),+PSS(3),400)=$G(PSSP50(50.1,PSS(3),400,"I"))
- ....S ^TMP($J,LIST,+PSS(2),+PSS(3),401)=$S($G(PSSP50(50.1,PSS(3),401,"I"))="":"",1:PSSP50(50.1,PSS(3),401,"I")_"^"_PSSP50(50.1,PSS(3),401,"E"))
- ....S ^TMP($J,LIST,+PSS(2),+PSS(3),402)=$G(PSSP50(50.1,PSS(3),402,"I"))
- ....S ^TMP($J,LIST,+PSS(2),+PSS(3),403)=$G(PSSP50(50.1,PSS(3),403,"I"))
- ....S ^TMP($J,LIST,+PSS(2),+PSS(3),404)=$G(PSSP50(50.1,PSS(3),404,"I"))
- ....S ^TMP($J,LIST,+PSS(2),+PSS(3),405)=$G(PSSP50(50.1,PSS(3),405,"I"))
- I ^TMP($J,LIST,0)'>0 S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND"
- K PSSP50
- Q
- ;
- SKAQ(PSSIEN2,PSSFL2) ;
- ;PSSIEN2 - IEN of entry in 50
- ;PSSFL2 - action flag - S to set the "AQ" cross-reference or
- ; K to kill the "AQ" cross-reference.
- ;
- I +$G(PSSIEN2)'>0 Q 0
- I "SK"'[$G(PSSFL2) Q 0
- I PSSFL2="S",$G(^PSDRUG(+PSSIEN2,3))=1 S ^PSDRUG("AQ",+PSSIEN2)="" Q 1
- I PSSFL2="K",+$G(^PSDRUG(+PSSIEN2,3))=0 K ^PSDRUG("AQ",+PSSIEN2) Q 1
- Q 0
- ;
- SKAQ1(PSSIEN2) ;
- ;PSSIEN2 - IEN of entry in 50
- I +$G(PSSIEN2)'>0 Q 0
- N PSS,QFLG S PSS="" F S PSS=$O(^PSDRUG("AQ1",PSS)) Q:PSS="" D
- .K ^PSDRUG("AQ1",PSS,+PSSIEN2) S QFLG=1
- .I $P($G(^PSDRUG(+PSSIEN2,"ND")),"^",10)]"" S ^PSDRUG("AQ1",$E($P($G(^PSDRUG(+PSSIEN2,"ND")),"^",10),1,30),+PSSIEN2)="" S QFLG=1
- I $D(QFLG) Q 1
- Q 0
- A526 ;
- ;PSSIEN - IEN of entry in 50
- ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST, of the data
- ; being returned.
- I $G(LIST)']"" Q
- K ^TMP($J,LIST)
- I +$G(PSSIEN)'>0 S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
- N PSS,CNT S (PSS,CNT)=0 F S PSS=$O(^PSDRUG("A526",+PSSIEN,PSS)) Q:'PSS D
- .S ^TMP($J,LIST,+PSS,.01)=$P($G(^PS(52.6,+PSS,0)),"^"),CNT=CNT+1
- .S ^TMP($J,LIST,"A526",$P($G(^PS(52.6,+PSS,0)),"^"),+PSS)=""
- S ^TMP($J,LIST,0)=$S(CNT>0:CNT,1:"-1^NO DATA FOUND")
- Q
- A527 ;
- ;PSSIEN - IEN of entry in 50
- ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST, of the data
- ; being returned.
- I $G(LIST)']"" Q
- K ^TMP($J,LIST)
- I +$G(PSSIEN)'>0 S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
- N PSS,CNT S (PSS,CNT)=0 F S PSS=$O(^PSDRUG("A527",+PSSIEN,PSS)) Q:'PSS D
- .S ^TMP($J,LIST,+PSS,.01)=$P($G(^PS(52.7,+PSS,0)),"^"),CNT=CNT+1
- .S ^TMP($J,LIST,"A527",$P($G(^PS(52.7,+PSS,0)),"^"),+PSS)=""
- S ^TMP($J,LIST,0)=$S(CNT>0:CNT,1:"-1^NO DATA FOUND")
- Q
- SKAIU(PSSIEN2,PSSFL2) ;
- ;PSSIEN2 - IEN of entry in 50
- ;PSSFL2 - action flag - S to set the "AIU" cross-reference or
- ; K to kill the "AIU" cross-reference
- ;
- I +$G(PSSIEN2)'>0 Q 0
- I "SK"'[$G(PSSFL2) Q 0
- N PSS,PSS2,PSSNM,PSSPK2,QFLG,PSSPK3
- S PSSPK3="INOSUWX"
- S PSSPK2=$P($G(^PSDRUG(+PSSIEN2,2)),"^",3),PSSNM=$P($G(^PSDRUG(+PSSIEN2,0)),"^")
- I PSSNM']"" Q 0
- I PSSNM]"" S PSS="" F PSS2=1:1:$L(PSSPK3) S PSS=$O(^PSDRUG("AIU"_$E(PSSPK3,PSS2))) Q:PSS="" D
- .K ^PSDRUG("AIU"_$E(PSSPK3,PSS2),PSSNM,+PSSIEN2) S:$G(PSSFL2)="K" QFLG=1
- I PSSPK2]"" F PSS=1:1:$L(PSSPK2) S ^PSDRUG("AIU"_$E(PSSPK2,PSS),PSSNM,PSSIEN2)="" S:$G(PSSFL2)="S" QFLG=1
- I $D(QFLG) Q 1
- Q 0
- SKIU(PSSIEN2) ;
- ;PSSIEN2 - IEN of entry in 50
- I +$G(PSSIEN2)'>0 Q 0
- N PSS,PSSPK2,QFLG S PSS="" F S PSS=$O(^PSDRUG("IU",PSS)) Q:PSS="" D
- .K ^PSDRUG("IU",PSS,+PSSIEN2) S QFLG=1
- .S PSSPK2=$P($G(^PSDRUG(+PSSIEN2,2)),"^",3)
- .I PSSPK2]"" S ^PSDRUG("IU",PSSPK2,+PSSIEN2)="" S QFLG=1
- I $D(QFLG) Q 1
- Q 0
- FNAME(PSSFNO2,PSSFILE2) ;
- I +$G(PSSFNO2)'>0!(+$G(PSSFILE2)'>0) Q ""
- N PSSNAME,PSSFFIND,PSSFILEZ,PSSFNUMB
- S PSSFILEZ=0
- I +$G(PSSFILE2)<60,+$G(PSSFILE2)'<50 S PSSFILEZ=1
- I 'PSSFILEZ F PSSFFIND=1:1 S PSSFNUMB=$P($T(FLIST+PSSFFIND),";;",2) Q:PSSFILEZ!(PSSFNUMB="") I PSSFNUMB=+$G(PSSFILE2) S PSSFILEZ=1
- I PSSFILEZ D FIELD^DID(+$G(PSSFILE2),PSSFNO2,"","LABEL","PSSNAME",)
- Q $G(PSSNAME("LABEL"))
- ;
- FLIST ;
- ;;550
- ;;550.04
- ;;550.07
- ;;550.08
- ;;550.09
- ;;550.1
- ;;550.11
- ;;550.1101
- ;;550.2
- ;;550.215
- ;;550.216
- ;;1020.1
- ;;1020.2
- ;;1020.3
- ;;1020.4
- ;;1020.5
- ;;1020.51
- ;;1020.6
- ;;1020.7
- ;;1020.8
- ;;9009032.3
- ;;9009032.4
- ;;9009032.411
- ;;9009032.412
- ;;9009032.413
- ;;9009032.414
- ;;9009032.415
- ;;9009032.416
- ;;9009032.5
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSS50E 8118 printed Mar 13, 2025@21:34:21 Page 2
- PSS50E ;BIR/LDT - API FOR INFORMATION FROM FILE 50; 5 Sep 03
- +1 ;;1.0;PHARMACY DATA MANAGEMENT;**85,104**;9/30/97
- +2 ;
- SKB(PSSIEN2,PSSFL2) ;
- +1 ;PSSIEN2 - IEN of entry in 50
- +2 ;PSSFL2 - action flag - S to set the "B" cross-reference or
- +3 ; K to kill the "B" cross-reference.
- +4 ;
- +5 IF +$GET(PSSIEN2)'>0
- QUIT 0
- +6 IF "SK"'[$GET(PSSFL2)
- QUIT 0
- +7 IF PSSFL2="S"
- IF $GET(^PSDRUG(+PSSIEN2,0))]""
- SET ^PSDRUG("B",$EXTRACT($PIECE($GET(^PSDRUG(+PSSIEN2,0)),"^"),1,40),+PSSIEN2)=""
- QUIT 1
- +8 IF PSSFL2="K"
- IF $GET(^PSDRUG(+PSSIEN2,0))]""
- KILL ^PSDRUG("B",$EXTRACT($PIECE($GET(^PSDRUG(+PSSIEN2,0)),"^"),1,40),+PSSIEN2)
- QUIT 1
- +9 QUIT 0
- +10 ;
- +11 IF $ASCII(PSSVAL)'=34
- SET PSSVAL=$CHAR(34)_PSSVAL_$CHAR(34)
- AOC ;
- +1 ;PSSVAL - VA CLASSIFICATION field (#2) of the DRUG file (#50)
- +2 ;PSSFL - Inactive flag - "" - All entries
- +3 ; FileMan Date - Only entries with no Inactive Date or an Inactive Date greater than this date.
- +4 ;PSSPK - Application Package's Use - "" - All entries
- +5 ; Alphabetic codes that represent the DHCP packages that consider this drug to be
- +6 ; part of their formulary.
- +7 ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is the Field Number of the data
- +8 ; piece being returned.
- +9 ;
- +10 NEW PSS
- +11 IF $GET(LIST)']""
- QUIT
- +12 KILL ^TMP($JOB,LIST)
- +13 IF $GET(PSSVAL)']""
- SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
- QUIT
- +14 SET ^TMP($JOB,LIST,0)=0
- +15 SET PSS(1)=0
- FOR
- SET PSS(1)=$ORDER(^PSDRUG("AOC",PSS(1)))
- if 'PSS(1)
- QUIT
- SET PSS(2)=""
- FOR
- SET PSS(2)=$ORDER(^PSDRUG("AOC",PSS(1),PSS(2)))
- if PSS(2)=""
- QUIT
- Begin DoDot:1
- +16 if PSS(2)'=PSSVAL
- QUIT
- SET PSS(3)=0
- FOR
- SET PSS(3)=$ORDER(^PSDRUG("AOC",PSS(1),PSS(2),PSS(3)))
- if 'PSS(3)
- QUIT
- Begin DoDot:2
- +17 NEW ZNODE,NODE2,INODE
- SET ZNODE=$GET(^PSDRUG(+PSS(3),0))
- SET NODE2=$GET(^(2))
- SET INODE=$GET(^("I"))
- +18 IF +$GET(PSSFL)>0
- IF +INODE>0
- IF +INODE'>PSSFL
- QUIT
- +19 ;Naked reference below refers to ^PSDRUG(+PSS(3),2)
- +20 IF $GET(PSSPK)]""
- NEW PSSZ5,PSSZ6
- SET PSSZ5=0
- FOR PSSZ6=1:1:$LENGTH(PSSPK)
- if PSSZ5
- QUIT
- IF $PIECE($GET(^(2)),"^",3)[$EXTRACT(PSSPK,PSSZ6)
- SET PSSZ5=1
- +21 IF $GET(PSSPK)]""
- IF 'PSSZ5
- QUIT
- +22 SET ^TMP($JOB,LIST,0)=^TMP($JOB,LIST,0)+1
- SET ^TMP($JOB,LIST,+PSS(3),.01)=$PIECE(ZNODE,"^")
- +23 SET ^TMP($JOB,LIST,"AOC",$PIECE(ZNODE,"^"),+PSS(3))=""
- End DoDot:2
- End DoDot:1
- +24 IF ^TMP($JOB,LIST,0)'>0
- SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
- +25 QUIT
- +26 ;
- C ;
- +1 ;PSSVAL - SYNONYM sub-field (#9) of the DRUG file (#50)
- +2 ;PSSFL - Inactive flag - "" - All entries
- +3 ; FileMan Date - Only entries with no Inactive Date or an Inactive Date greater than this date.
- +4 ;PSSPK - Application Package's Use - "" - All entries
- +5 ; Alphabetic codes that represent the DHCP packages that consider this drug to be
- +6 ; part of their formulary.
- +7 ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is the Field Number of the data
- +8 ; piece being returned.
- +9 ;
- +10 NEW DIERR,ZZERR,PSS,PSSP50
- +11 IF $GET(LIST)']""
- QUIT
- +12 KILL ^TMP($JOB,LIST)
- +13 IF $GET(PSSVAL)']""
- SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
- QUIT
- +14 SET ^TMP($JOB,LIST,0)=0
- +15 SET PSS(1)=""
- FOR
- SET PSS(1)=$ORDER(^PSDRUG("C",PSS(1)))
- if PSS(1)=""
- QUIT
- SET PSS(2)=""
- FOR
- SET PSS(2)=$ORDER(^PSDRUG("C",PSS(1),PSS(2)))
- if PSS(2)=""
- QUIT
- Begin DoDot:1
- +16 if PSS(1)'=PSSVAL
- QUIT
- Begin DoDot:2
- +17 NEW ZNODE,NODE2,INODE
- SET ZNODE=$GET(^PSDRUG(+PSS(2),0))
- SET NODE2=$GET(^(2))
- SET INODE=$PIECE($GET(^("I")),"^")
- +18 IF +$GET(PSSFL)>0
- IF +INODE>0
- IF +INODE'>PSSFL
- QUIT
- +19 ;Naked reference below refers to ^PSDRUG(+PSS(2),2)
- +20 IF $GET(PSSPK)]""
- NEW PSSZ5,PSSZ6
- SET PSSZ5=0
- FOR PSSZ6=1:1:$LENGTH(PSSPK)
- if PSSZ5
- QUIT
- IF $PIECE($GET(^(2)),"^",3)[$EXTRACT(PSSPK,PSSZ6)
- SET PSSZ5=1
- +21 IF $GET(PSSPK)]""
- IF 'PSSZ5
- QUIT
- +22 SET ^TMP($JOB,LIST,0)=^TMP($JOB,LIST,0)+1
- SET ^TMP($JOB,LIST,+PSS(2),.01)=$PIECE(ZNODE,"^")
- SET ^TMP($JOB,LIST,"C",$PIECE(ZNODE,"^"),+PSS(2))=""
- Begin DoDot:3
- +23 KILL PSSP50
- DO GETS^DIQ(50,+PSS(2),"9*","IE","PSSP50")
- SET PSS(3)=0
- +24 FOR
- SET PSS(3)=$ORDER(PSSP50(50.1,PSS(3)))
- if 'PSS(3)
- QUIT
- Begin DoDot:4
- +25 SET ^TMP($JOB,LIST,+PSS(2),+PSS(3),.01)=$GET(PSSP50(50.1,PSS(3),.01,"I"))
- +26 SET ^TMP($JOB,LIST,+PSS(2),+PSS(3),2)=$GET(PSSP50(50.1,PSS(3),2,"I"))
- +27 SET ^TMP($JOB,LIST,+PSS(2),+PSS(3),1)=$SELECT($GET(PSSP50(50.1,PSS(3),1,"I"))="":"",1:PSSP50(50.1,PSS(3),1,"I")_"^"_PSSP50(50.1,PSS(3),1,"E"))
- +28 SET ^TMP($JOB,LIST,+PSS(2),+PSS(3),400)=$GET(PSSP50(50.1,PSS(3),400,"I"))
- +29 SET ^TMP($JOB,LIST,+PSS(2),+PSS(3),401)=$SELECT($GET(PSSP50(50.1,PSS(3),401,"I"))="":"",1:PSSP50(50.1,PSS(3),401,"I")_"^"_PSSP50(50.1,PSS(3),401,"E"))
- +30 SET ^TMP($JOB,LIST,+PSS(2),+PSS(3),402)=$GET(PSSP50(50.1,PSS(3),402,"I"))
- +31 SET ^TMP($JOB,LIST,+PSS(2),+PSS(3),403)=$GET(PSSP50(50.1,PSS(3),403,"I"))
- +32 SET ^TMP($JOB,LIST,+PSS(2),+PSS(3),404)=$GET(PSSP50(50.1,PSS(3),404,"I"))
- +33 SET ^TMP($JOB,LIST,+PSS(2),+PSS(3),405)=$GET(PSSP50(50.1,PSS(3),405,"I"))
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +34 IF ^TMP($JOB,LIST,0)'>0
- SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
- +35 KILL PSSP50
- +36 QUIT
- +37 ;
- SKAQ(PSSIEN2,PSSFL2) ;
- +1 ;PSSIEN2 - IEN of entry in 50
- +2 ;PSSFL2 - action flag - S to set the "AQ" cross-reference or
- +3 ; K to kill the "AQ" cross-reference.
- +4 ;
- +5 IF +$GET(PSSIEN2)'>0
- QUIT 0
- +6 IF "SK"'[$GET(PSSFL2)
- QUIT 0
- +7 IF PSSFL2="S"
- IF $GET(^PSDRUG(+PSSIEN2,3))=1
- SET ^PSDRUG("AQ",+PSSIEN2)=""
- QUIT 1
- +8 IF PSSFL2="K"
- IF +$GET(^PSDRUG(+PSSIEN2,3))=0
- KILL ^PSDRUG("AQ",+PSSIEN2)
- QUIT 1
- +9 QUIT 0
- +10 ;
- SKAQ1(PSSIEN2) ;
- +1 ;PSSIEN2 - IEN of entry in 50
- +2 IF +$GET(PSSIEN2)'>0
- QUIT 0
- +3 NEW PSS,QFLG
- SET PSS=""
- FOR
- SET PSS=$ORDER(^PSDRUG("AQ1",PSS))
- if PSS=""
- QUIT
- Begin DoDot:1
- +4 KILL ^PSDRUG("AQ1",PSS,+PSSIEN2)
- SET QFLG=1
- +5 IF $PIECE($GET(^PSDRUG(+PSSIEN2,"ND")),"^",10)]""
- SET ^PSDRUG("AQ1",$EXTRACT($PIECE($GET(^PSDRUG(+PSSIEN2,"ND")),"^",10),1,30),+PSSIEN2)=""
- SET QFLG=1
- End DoDot:1
- +6 IF $DATA(QFLG)
- QUIT 1
- +7 QUIT 0
- A526 ;
- +1 ;PSSIEN - IEN of entry in 50
- +2 ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST, of the data
- +3 ; being returned.
- +4 IF $GET(LIST)']""
- QUIT
- +5 KILL ^TMP($JOB,LIST)
- +6 IF +$GET(PSSIEN)'>0
- SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
- QUIT
- +7 NEW PSS,CNT
- SET (PSS,CNT)=0
- FOR
- SET PSS=$ORDER(^PSDRUG("A526",+PSSIEN,PSS))
- if 'PSS
- QUIT
- Begin DoDot:1
- +8 SET ^TMP($JOB,LIST,+PSS,.01)=$PIECE($GET(^PS(52.6,+PSS,0)),"^")
- SET CNT=CNT+1
- +9 SET ^TMP($JOB,LIST,"A526",$PIECE($GET(^PS(52.6,+PSS,0)),"^"),+PSS)=""
- End DoDot:1
- +10 SET ^TMP($JOB,LIST,0)=$SELECT(CNT>0:CNT,1:"-1^NO DATA FOUND")
- +11 QUIT
- A527 ;
- +1 ;PSSIEN - IEN of entry in 50
- +2 ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST, of the data
- +3 ; being returned.
- +4 IF $GET(LIST)']""
- QUIT
- +5 KILL ^TMP($JOB,LIST)
- +6 IF +$GET(PSSIEN)'>0
- SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
- QUIT
- +7 NEW PSS,CNT
- SET (PSS,CNT)=0
- FOR
- SET PSS=$ORDER(^PSDRUG("A527",+PSSIEN,PSS))
- if 'PSS
- QUIT
- Begin DoDot:1
- +8 SET ^TMP($JOB,LIST,+PSS,.01)=$PIECE($GET(^PS(52.7,+PSS,0)),"^")
- SET CNT=CNT+1
- +9 SET ^TMP($JOB,LIST,"A527",$PIECE($GET(^PS(52.7,+PSS,0)),"^"),+PSS)=""
- End DoDot:1
- +10 SET ^TMP($JOB,LIST,0)=$SELECT(CNT>0:CNT,1:"-1^NO DATA FOUND")
- +11 QUIT
- SKAIU(PSSIEN2,PSSFL2) ;
- +1 ;PSSIEN2 - IEN of entry in 50
- +2 ;PSSFL2 - action flag - S to set the "AIU" cross-reference or
- +3 ; K to kill the "AIU" cross-reference
- +4 ;
- +5 IF +$GET(PSSIEN2)'>0
- QUIT 0
- +6 IF "SK"'[$GET(PSSFL2)
- QUIT 0
- +7 NEW PSS,PSS2,PSSNM,PSSPK2,QFLG,PSSPK3
- +8 SET PSSPK3="INOSUWX"
- +9 SET PSSPK2=$PIECE($GET(^PSDRUG(+PSSIEN2,2)),"^",3)
- SET PSSNM=$PIECE($GET(^PSDRUG(+PSSIEN2,0)),"^")
- +10 IF PSSNM']""
- QUIT 0
- +11 IF PSSNM]""
- SET PSS=""
- FOR PSS2=1:1:$LENGTH(PSSPK3)
- SET PSS=$ORDER(^PSDRUG("AIU"_$EXTRACT(PSSPK3,PSS2)))
- if PSS=""
- QUIT
- Begin DoDot:1
- +12 KILL ^PSDRUG("AIU"_$EXTRACT(PSSPK3,PSS2),PSSNM,+PSSIEN2)
- if $GET(PSSFL2)="K"
- SET QFLG=1
- End DoDot:1
- +13 IF PSSPK2]""
- FOR PSS=1:1:$LENGTH(PSSPK2)
- SET ^PSDRUG("AIU"_$EXTRACT(PSSPK2,PSS),PSSNM,PSSIEN2)=""
- if $GET(PSSFL2)="S"
- SET QFLG=1
- +14 IF $DATA(QFLG)
- QUIT 1
- +15 QUIT 0
- SKIU(PSSIEN2) ;
- +1 ;PSSIEN2 - IEN of entry in 50
- +2 IF +$GET(PSSIEN2)'>0
- QUIT 0
- +3 NEW PSS,PSSPK2,QFLG
- SET PSS=""
- FOR
- SET PSS=$ORDER(^PSDRUG("IU",PSS))
- if PSS=""
- QUIT
- Begin DoDot:1
- +4 KILL ^PSDRUG("IU",PSS,+PSSIEN2)
- SET QFLG=1
- +5 SET PSSPK2=$PIECE($GET(^PSDRUG(+PSSIEN2,2)),"^",3)
- +6 IF PSSPK2]""
- SET ^PSDRUG("IU",PSSPK2,+PSSIEN2)=""
- SET QFLG=1
- End DoDot:1
- +7 IF $DATA(QFLG)
- QUIT 1
- +8 QUIT 0
- FNAME(PSSFNO2,PSSFILE2) ;
- +1 IF +$GET(PSSFNO2)'>0!(+$GET(PSSFILE2)'>0)
- QUIT ""
- +2 NEW PSSNAME,PSSFFIND,PSSFILEZ,PSSFNUMB
- +3 SET PSSFILEZ=0
- +4 IF +$GET(PSSFILE2)<60
- IF +$GET(PSSFILE2)'<50
- SET PSSFILEZ=1
- +5 IF 'PSSFILEZ
- FOR PSSFFIND=1:1
- SET PSSFNUMB=$PIECE($TEXT(FLIST+PSSFFIND),";;",2)
- if PSSFILEZ!(PSSFNUMB="")
- QUIT
- IF PSSFNUMB=+$GET(PSSFILE2)
- SET PSSFILEZ=1
- +6 IF PSSFILEZ
- DO FIELD^DID(+$GET(PSSFILE2),PSSFNO2,"","LABEL","PSSNAME",)
- +7 QUIT $GET(PSSNAME("LABEL"))
- +8 ;
- FLIST ;
- +1 ;;550
- +2 ;;550.04
- +3 ;;550.07
- +4 ;;550.08
- +5 ;;550.09
- +6 ;;550.1
- +7 ;;550.11
- +8 ;;550.1101
- +9 ;;550.2
- +10 ;;550.215
- +11 ;;550.216
- +12 ;;1020.1
- +13 ;;1020.2
- +14 ;;1020.3
- +15 ;;1020.4
- +16 ;;1020.5
- +17 ;;1020.51
- +18 ;;1020.6
- +19 ;;1020.7
- +20 ;;1020.8
- +21 ;;9009032.3
- +22 ;;9009032.4
- +23 ;;9009032.411
- +24 ;;9009032.412
- +25 ;;9009032.413
- +26 ;;9009032.414
- +27 ;;9009032.415
- +28 ;;9009032.416
- +29 ;;9009032.5
- +30 QUIT
