- PSS50DAT ;BHAM ISC/TSS - CONTINUATION OF API FOR INFORMATION FROM FILE 50; 5 Sep 03
- ;;1.0;PHARMACY DATA MANAGEMENT;**85,92,112,118**;9/30/97;Build 8
- DATA ;
- ;PSSIEN - IEN of entry in 50
- ;PSSFT - Free Text name in 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.
- ;PSSRTOI - Orderable Item - return only entries matched to a Pharmacy Orderable Item
- ;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.
- ;Reference to ^PSNDF(50.68 is supported by DBIA 3735
- ;NEW UNPROTECTED FILEMAN VARIABLES
- N DO,DINDEX,DISUB,DIVAL
- N PSSBGCNT
- N PSSCNT
- N PSSTIEN
- N PSSTMP
- N PSSOLD
- N PSSALT
- N PSSMATCH
- N PSSSYN
- N PSSCAP
- S PSSBGCNT=0
- S SCR("S")=""
- I $G(LIST)']"" Q
- I +$G(PSSIEN)'>0,($G(PSSFT)']"") S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
- K ^TMP("DILIST",$J)
- K ^TMP($J,LIST)
- S SCR("S")=""
- I +$G(PSSFL)>0!($G(PSSPK)]"")!($G(PSSRTOI)=1) N PSS5ND,PSSZ3,PSSZ4 D SETSCRN^PSS50A
- I +$G(PSSIEN)>0 N PSSIEN2 S PSSIEN2=$$FIND1^DIC(50,"","A","`"_PSSIEN,,SCR("S"),"") D K ^TMP("PSSP50",$J) D COUNTBG Q
- .I PSSIEN2>0 D DIRREAD
- I +$G(PSSIEN)=0 D
- .I PSSFT="??" D LOOPDIR D COUNTBG Q
- .D FIND^DIC(50,,"@;.01","QP",PSSFT,,"B",SCR("S"),,"") D LOOPDI D COUNTBG
- Q
- ;
- COUNTBG ;CHECKS PSSBGCNT AND FILLS COUNT IN ON 0 NODE OF ^TMP($J,LIST)
- I PSSBGCNT>0 D
- .S ^TMP($J,LIST,0)=PSSBGCNT
- ELSE S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND"
- Q
- ;
- LOOPDI ;LOOPS ON "DILIST" FROM FILEMAN CALL (USED FOR RETURNING MULTIPLE DRUGS FROM PSSFT)
- S PSSTIEN=0 ;TEMP IEN TO ITERATE OVER DILIST
- F S PSSTIEN=$O(^TMP("DILIST",$J,PSSTIEN)) Q:PSSTIEN="" D
- .S PSSIEN2=($P(^TMP("DILIST",$J,PSSTIEN,0),U,1))
- .D DIRREAD
- Q
- ;
- LOOPDIR ;LOOP FOR A DIRECT READ. READS ALL IENs FOR ^PSDRUG(
- S PSSIEN2=0
- F S PSSIEN2=$O(^PSDRUG(PSSIEN2)) Q:'PSSIEN2 D
- .I $P($G(^PSDRUG(PSSIEN2,0)),U,1)'="" D DIRALL
- Q
- ;
- DIRALL ;TEST FOR PSSFL, PSSRTOI, PSSPK, BAILS IF CONDITIONS MEET TRUE
- I $G(PSSFL),$P($G(^PSDRUG(PSSIEN2,"I")),"^"),$P($G(^("I")),"^")'>PSSFL Q
- I $G(PSSRTOI)=1,'$P($G(^PSDRUG(PSSIEN2,2)),"^") Q
- I $G(PSSPK)]"" N PSSZ5,PSSZ6 S PSSZ5=0 F PSSZ6=1:1:$L(PSSPK) Q:PSSZ5 I $P($G(^PSDRUG(PSSIEN2,2)),U,3)[$E(PSSPK,PSSZ6) S PSSZ5=1
- I $G(PSSPK)]"",'PSSZ5 Q
- D DIRREAD
- Q
- ;
- DIRREAD ;MAIN DIRECT READ FOR ENTIRE ROUTINE
- D DIRREAD^PSS50TMP
- D SYNONYM
- S ^TMP($J,LIST,"B",$G(^TMP($J,LIST,PSSIEN2,.01)),PSSIEN2)=""
- D FORMALT
- D OLD
- D SRVCODE($P(^TMP($J,LIST,PSSIEN2,22),U,1))
- S PSSBGCNT=PSSBGCNT+1
- Q
- ;
- SYNONYM ; FILLS SYNONYM MULTIPLE
- S PSSCNT=0
- S PSSTMP=""
- S PSSSYN=""
- F S PSSSYN=$O(^PSDRUG(PSSIEN2,1,PSSSYN)) Q:PSSSYN="" D
- .I $P($G(^PSDRUG(PSSIEN2,1,PSSSYN,0)),U,1)'="" D
- ..S ^TMP($J,LIST,PSSIEN2,"SYN",PSSSYN,.01)=$P($G(^PSDRUG(PSSIEN2,1,PSSSYN,0)),U,1)
- ..;;;;;INTENDED USE
- ..S PSSTMP=$P($G(^PSDRUG(PSSIEN2,1,PSSSYN,0)),U,3)
- ..I PSSTMP="0" S ^TMP($J,LIST,PSSIEN2,"SYN",PSSSYN,1)=PSSTMP_U_"TRADE NAME"
- ..I PSSTMP="1" S ^TMP($J,LIST,PSSIEN2,"SYN",PSSSYN,1)=PSSTMP_U_"QUICK CODE"
- ..I PSSTMP="D" S ^TMP($J,LIST,PSSIEN2,"SYN",PSSSYN,1)=PSSTMP_U_"DRUG ACCOUNTABILITY"
- ..I PSSTMP="C" S ^TMP($J,LIST,PSSIEN2,"SYN",PSSSYN,1)=PSSTMP_U_"CONTROLLED SUBSTANCES"
- ..I PSSTMP="" S ^TMP($J,LIST,PSSIEN2,"SYN",PSSSYN,1)=""
- ..;;;;;NDC CODE
- ..S ^TMP($J,LIST,PSSIEN2,"SYN",PSSSYN,2)=$P($G(^PSDRUG(PSSIEN2,1,PSSSYN,0)),U,2)
- ..S ^TMP($J,LIST,PSSIEN2,"SYN",PSSSYN,403)=$P($G(^PSDRUG(PSSIEN2,1,PSSSYN,0)),U,7)
- ..S PSSCNT=PSSCNT+1
- I PSSCNT=0 S ^TMP($J,LIST,PSSIEN2,"SYN",0)="-1^NO DATA FOUND"
- ELSE S ^TMP($J,LIST,PSSIEN2,"SYN",0)=PSSCNT
- Q
- ;
- FORMALT ;FILLS FORMULARY ALTERATIVE MULTIPLE
- S PSSCNT=0
- S PSSALT=0
- F S PSSALT=$O(^PSDRUG(PSSIEN2,65,PSSALT)) Q:PSSALT="" D
- .I $P($G(^PSDRUG(PSSIEN2,65,PSSALT,0)),U,1)'="" D
- ..S ^TMP($J,LIST,PSSIEN2,"FRM",PSSALT,2)=$P($G(^PSDRUG(PSSIEN2,65,PSSALT,0)),U,1)_U_$P($G(^PSDRUG($P($G(^PSDRUG(PSSIEN2,65,PSSALT,0)),U,1),0)),U,1)
- ..S PSSCNT=PSSCNT+1
- I PSSCNT=0 S ^TMP($J,LIST,PSSIEN2,"FRM",0)="-1^NO DATA FOUND"
- ELSE S ^TMP($J,LIST,PSSIEN2,"FRM",0)=PSSCNT
- Q
- ;
- OLD ;FILLS THE OLD NAME MULTIPLE
- S PSSCNT=0
- S PSSOLD=0
- F S PSSOLD=$O(^PSDRUG(PSSIEN2,900,PSSOLD)) Q:PSSOLD="" D
- .I $P($G(^PSDRUG(PSSIEN2,900,PSSOLD,0)),U,2)'="" D
- ..S PSSCAP=$$UP^XLFSTR($$FMTE^XLFDT($P(^PSDRUG(PSSIEN2,900,PSSOLD,0),U,2)))
- ..S ^TMP($J,LIST,PSSIEN2,"OLD",PSSOLD,.02)=$P($G(^PSDRUG(PSSIEN2,900,PSSOLD,0)),U,2)_U_PSSCAP
- .ELSE S ^TMP($J,LIST,PSSIEN2,"OLD",PSSOLD,.02)=""
- .I $P($G(^PSDRUG(PSSIEN2,900,PSSOLD,0)),U,1)'="" D
- ..S ^TMP($J,LIST,PSSIEN2,"OLD",PSSOLD,.01)=$P($G(^PSDRUG(PSSIEN2,900,PSSOLD,0)),U,1)
- ..S PSSCNT=PSSCNT+1
- .ELSE S ^TMP($J,LIST,PSSIEN2,"OLD",PSSOLD,.01)=""
- I PSSCNT=0 S ^TMP($J,LIST,PSSIEN2,"OLD",0)="-1^NO DATA FOUND"
- ELSE S ^TMP($J,LIST,PSSIEN2,"OLD",0)=PSSCNT
- Q
- ;
- SRVCODE(PSSMATCH) ;FILLS SERVICE CODE MULTIPLE
- I PSSMATCH'="" S ^TMP($J,LIST,PSSIEN2,400)=$P($G(^PSNDF(50.68,PSSMATCH,"PFS")),U,1)
- I $P($G(^TMP($J,LIST,PSSIEN2,400)),U,1)="" S ^TMP($J,LIST,PSSIEN2,400)=$P($G(^PSDRUG(PSSIEN2,"PFS")),U,1)
- I $P($G(^TMP($J,LIST,PSSIEN2,400)),U,1)="" S ^TMP($J,LIST,PSSIEN2,400)=600000
- Q
- ;
- DRG ;
- ;PSSIEN - IEN of entry in 50
- ;PSSFT - Free Text name in 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.
- ;PSSRTOI - Orderable Item - return only entries matched to a Pharmacy Orderable Item
- ;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,PSSP50,SCR,PSS,PSSMLCT
- I $G(LIST)']"" Q
- K ^TMP($J,LIST)
- I +$G(PSSIEN)'>0,($G(PSSFT)']"") S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
- S SCR("S")=""
- I +$G(PSSFL)>0!($G(PSSPK)]"")!($G(PSSRTOI)=1) N PSS5ND,PSSZ3,PSSZ4 D SETSCRN^PSS50A
- I +$G(PSSIEN)>0 N PSSIEN2 S PSSIEN2=$$FIND1^DIC(50,"","A","`"_PSSIEN,,SCR("S"),"") D K ^TMP("PSSP50",$J) Q
- .K ^TMP("DIERR",$J)
- .I +PSSIEN2'>0 S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
- .S ^TMP($J,LIST,0)=1
- .K ^TMP("PSSP50",$J) D GETS^DIQ(50,+PSSIEN2,".01;62.01:62.05;905","IE","^TMP(""PSSP50"",$J)") S PSS(1)=0
- .F S PSS(1)=$O(^TMP("PSSP50",$J,50,PSS(1))) Q:'PSS(1) D SETDRG^PSS50A1
- I $G(PSSIEN)'="" S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
- I $G(PSSFT)]"" D
- .I PSSFT["??" D LOOP^PSS50A1 Q
- .K ^TMP("DILIST",$J)
- .D FIND^DIC(50,,"@;.01","QP",PSSFT,,"B",SCR("S"),,"")
- .I +$G(^TMP("DILIST",$J,0))=0 S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
- .I +^TMP("DILIST",$J,0)>0 S ^TMP($J,LIST,0)=+^TMP("DILIST",$J,0) N PSSXX S PSSXX=0 F S PSSXX=$O(^TMP("DILIST",$J,PSSXX)) Q:'PSSXX D
- ..S PSSIEN=+^TMP("DILIST",$J,PSSXX,0)
- ..K ^TMP("PSSP50",$J) D GETS^DIQ(50,+PSSIEN,".01;62.01:62.05;905","IE","^TMP(""PSSP50"",$J)") S PSS(1)=0
- ..F S PSS(1)=$O(^TMP("PSSP50",$J,50,PSS(1))) Q:'PSS(1) D SETDRG^PSS50A1
- K ^TMP("DILIST",$J),^TMP("PSSP50",$J)
- Q
- ;
- LOOP ;
- N PSS50DD1,PSS50DD2,PSS50DD3,PSS50DD4,PSS50ER1,PSS50ER2,PSS50ER3,PSS50ER4,PSS51NFD,PSS52NFD,PSSG2N,PSS501NX
- D FIELD^DID(50,51,"Z","POINTER","PSS50DD1","PSS50ER1") S PSS51NFD=$G(PSS50DD1("POINTER"))
- D FIELD^DID(50,52,"Z","POINTER","PSS50DD2","PSS50ER2") S PSS52NFD=$G(PSS50DD2("POINTER"))
- D FIELD^DID(50,301,"Z","POINTER","PSS50DD3","PSS50ER3") S PSSG2N=$G(PSS50DD3("POINTER"))
- D FIELD^DID(50.1,1,"Z","POINTER","PSS50DD4","PSS50ER4") S PSS501NX=$G(PSS50DD4("POINTER"))
- N PSSENCT
- S PSSENCT=0
- S PSS(1)=0 F S PSS(1)=$O(^PSDRUG(PSS(1))) Q:'PSS(1) D
- .I $P($G(^PSDRUG(PSS(1),0)),"^")="" Q
- .I $G(PSSFL),$P($G(^PSDRUG(PSS(1),"I")),"^"),$P($G(^("I")),"^")'>PSSFL Q
- .I $G(PSSRTOI)=1,'$P($G(^PSDRUG(PSS(1),2)),"^") Q
- .;Naked reference below refers to ^PSDRUG(PSS(1),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
- .D SETSUB1^PSS50AQM(PSS(1)),SETSUB2^PSS50AQM(PSS(1)),SETSUB3^PSS50AQM(PSS(1))
- .D SETALL^PSS50AQM,SETOLD^PSS50AQM,SETSYN^PSS50AQM,SETFMA^PSS50AQM
- .S PSSENCT=PSSENCT+1
- S ^TMP($J,LIST,0)=$S($G(PSSENCT):$G(PSSENCT),1:"-1^NO DATA FOUND")
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSS50DAT 8789 printed Jan 18, 2025@03:30:32 Page 2
- PSS50DAT ;BHAM ISC/TSS - CONTINUATION OF API FOR INFORMATION FROM FILE 50; 5 Sep 03
- +1 ;;1.0;PHARMACY DATA MANAGEMENT;**85,92,112,118**;9/30/97;Build 8
- DATA ;
- +1 ;PSSIEN - IEN of entry in 50
- +2 ;PSSFT - Free Text name in 50
- +3 ;PSSFL - Inactive flag - "" - All entries
- +4 ; FileMan Date - Only entries with no Inactive Date or an Inactive Date greater than this date.
- +5 ;PSSPK - Application Package's Use - "" - All entries
- +6 ; Alphabetic codes that represent the DHCP packages that consider this drug to be
- +7 ; part of their formulary.
- +8 ;PSSRTOI - Orderable Item - return only entries matched to a Pharmacy Orderable Item
- +9 ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is the Field Number of the data
- +10 ; piece being returned.
- +11 ;Reference to ^PSNDF(50.68 is supported by DBIA 3735
- +12 ;NEW UNPROTECTED FILEMAN VARIABLES
- +13 NEW DO,DINDEX,DISUB,DIVAL
- +14 NEW PSSBGCNT
- +15 NEW PSSCNT
- +16 NEW PSSTIEN
- +17 NEW PSSTMP
- +18 NEW PSSOLD
- +19 NEW PSSALT
- +20 NEW PSSMATCH
- +21 NEW PSSSYN
- +22 NEW PSSCAP
- +23 SET PSSBGCNT=0
- +24 SET SCR("S")=""
- +25 IF $GET(LIST)']""
- QUIT
- +26 IF +$GET(PSSIEN)'>0
- IF ($GET(PSSFT)']"")
- SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
- QUIT
- +27 KILL ^TMP("DILIST",$JOB)
- +28 KILL ^TMP($JOB,LIST)
- +29 SET SCR("S")=""
- +30 IF +$GET(PSSFL)>0!($GET(PSSPK)]"")!($GET(PSSRTOI)=1)
- NEW PSS5ND,PSSZ3,PSSZ4
- DO SETSCRN^PSS50A
- +31 IF +$GET(PSSIEN)>0
- NEW PSSIEN2
- SET PSSIEN2=$$FIND1^DIC(50,"","A","`"_PSSIEN,,SCR("S"),"")
- Begin DoDot:1
- +32 IF PSSIEN2>0
- DO DIRREAD
- End DoDot:1
- KILL ^TMP("PSSP50",$JOB)
- DO COUNTBG
- QUIT
- +33 IF +$GET(PSSIEN)=0
- Begin DoDot:1
- +34 IF PSSFT="??"
- DO LOOPDIR
- DO COUNTBG
- QUIT
- +35 DO FIND^DIC(50,,"@;.01","QP",PSSFT,,"B",SCR("S"),,"")
- DO LOOPDI
- DO COUNTBG
- End DoDot:1
- +36 QUIT
- +37 ;
- COUNTBG ;CHECKS PSSBGCNT AND FILLS COUNT IN ON 0 NODE OF ^TMP($J,LIST)
- +1 IF PSSBGCNT>0
- Begin DoDot:1
- +2 SET ^TMP($JOB,LIST,0)=PSSBGCNT
- End DoDot:1
- +3 IF '$TEST
- SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
- +4 QUIT
- +5 ;
- LOOPDI ;LOOPS ON "DILIST" FROM FILEMAN CALL (USED FOR RETURNING MULTIPLE DRUGS FROM PSSFT)
- +1 ;TEMP IEN TO ITERATE OVER DILIST
- SET PSSTIEN=0
- +2 FOR
- SET PSSTIEN=$ORDER(^TMP("DILIST",$JOB,PSSTIEN))
- if PSSTIEN=""
- QUIT
- Begin DoDot:1
- +3 SET PSSIEN2=($PIECE(^TMP("DILIST",$JOB,PSSTIEN,0),U,1))
- +4 DO DIRREAD
- End DoDot:1
- +5 QUIT
- +6 ;
- LOOPDIR ;LOOP FOR A DIRECT READ. READS ALL IENs FOR ^PSDRUG(
- +1 SET PSSIEN2=0
- +2 FOR
- SET PSSIEN2=$ORDER(^PSDRUG(PSSIEN2))
- if 'PSSIEN2
- QUIT
- Begin DoDot:1
- +3 IF $PIECE($GET(^PSDRUG(PSSIEN2,0)),U,1)'=""
- DO DIRALL
- End DoDot:1
- +4 QUIT
- +5 ;
- DIRALL ;TEST FOR PSSFL, PSSRTOI, PSSPK, BAILS IF CONDITIONS MEET TRUE
- +1 IF $GET(PSSFL)
- IF $PIECE($GET(^PSDRUG(PSSIEN2,"I")),"^")
- IF $PIECE($GET(^("I")),"^")'>PSSFL
- QUIT
- +2 IF $GET(PSSRTOI)=1
- IF '$PIECE($GET(^PSDRUG(PSSIEN2,2)),"^")
- QUIT
- +3 IF $GET(PSSPK)]""
- NEW PSSZ5,PSSZ6
- SET PSSZ5=0
- FOR PSSZ6=1:1:$LENGTH(PSSPK)
- if PSSZ5
- QUIT
- IF $PIECE($GET(^PSDRUG(PSSIEN2,2)),U,3)[$EXTRACT(PSSPK,PSSZ6)
- SET PSSZ5=1
- +4 IF $GET(PSSPK)]""
- IF 'PSSZ5
- QUIT
- +5 DO DIRREAD
- +6 QUIT
- +7 ;
- DIRREAD ;MAIN DIRECT READ FOR ENTIRE ROUTINE
- +1 DO DIRREAD^PSS50TMP
- +2 DO SYNONYM
- +3 SET ^TMP($JOB,LIST,"B",$GET(^TMP($JOB,LIST,PSSIEN2,.01)),PSSIEN2)=""
- +4 DO FORMALT
- +5 DO OLD
- +6 DO SRVCODE($PIECE(^TMP($JOB,LIST,PSSIEN2,22),U,1))
- +7 SET PSSBGCNT=PSSBGCNT+1
- +8 QUIT
- +9 ;
- SYNONYM ; FILLS SYNONYM MULTIPLE
- +1 SET PSSCNT=0
- +2 SET PSSTMP=""
- +3 SET PSSSYN=""
- +4 FOR
- SET PSSSYN=$ORDER(^PSDRUG(PSSIEN2,1,PSSSYN))
- if PSSSYN=""
- QUIT
- Begin DoDot:1
- +5 IF $PIECE($GET(^PSDRUG(PSSIEN2,1,PSSSYN,0)),U,1)'=""
- Begin DoDot:2
- +6 SET ^TMP($JOB,LIST,PSSIEN2,"SYN",PSSSYN,.01)=$PIECE($GET(^PSDRUG(PSSIEN2,1,PSSSYN,0)),U,1)
- +7 ;;;;;INTENDED USE
- +8 SET PSSTMP=$PIECE($GET(^PSDRUG(PSSIEN2,1,PSSSYN,0)),U,3)
- +9 IF PSSTMP="0"
- SET ^TMP($JOB,LIST,PSSIEN2,"SYN",PSSSYN,1)=PSSTMP_U_"TRADE NAME"
- +10 IF PSSTMP="1"
- SET ^TMP($JOB,LIST,PSSIEN2,"SYN",PSSSYN,1)=PSSTMP_U_"QUICK CODE"
- +11 IF PSSTMP="D"
- SET ^TMP($JOB,LIST,PSSIEN2,"SYN",PSSSYN,1)=PSSTMP_U_"DRUG ACCOUNTABILITY"
- +12 IF PSSTMP="C"
- SET ^TMP($JOB,LIST,PSSIEN2,"SYN",PSSSYN,1)=PSSTMP_U_"CONTROLLED SUBSTANCES"
- +13 IF PSSTMP=""
- SET ^TMP($JOB,LIST,PSSIEN2,"SYN",PSSSYN,1)=""
- +14 ;;;;;NDC CODE
- +15 SET ^TMP($JOB,LIST,PSSIEN2,"SYN",PSSSYN,2)=$PIECE($GET(^PSDRUG(PSSIEN2,1,PSSSYN,0)),U,2)
- +16 SET ^TMP($JOB,LIST,PSSIEN2,"SYN",PSSSYN,403)=$PIECE($GET(^PSDRUG(PSSIEN2,1,PSSSYN,0)),U,7)
- +17 SET PSSCNT=PSSCNT+1
- End DoDot:2
- End DoDot:1
- +18 IF PSSCNT=0
- SET ^TMP($JOB,LIST,PSSIEN2,"SYN",0)="-1^NO DATA FOUND"
- +19 IF '$TEST
- SET ^TMP($JOB,LIST,PSSIEN2,"SYN",0)=PSSCNT
- +20 QUIT
- +21 ;
- FORMALT ;FILLS FORMULARY ALTERATIVE MULTIPLE
- +1 SET PSSCNT=0
- +2 SET PSSALT=0
- +3 FOR
- SET PSSALT=$ORDER(^PSDRUG(PSSIEN2,65,PSSALT))
- if PSSALT=""
- QUIT
- Begin DoDot:1
- +4 IF $PIECE($GET(^PSDRUG(PSSIEN2,65,PSSALT,0)),U,1)'=""
- Begin DoDot:2
- +5 SET ^TMP($JOB,LIST,PSSIEN2,"FRM",PSSALT,2)=$PIECE($GET(^PSDRUG(PSSIEN2,65,PSSALT,0)),U,1)_U_$PIECE($GET(^PSDRUG($PIECE($GET(^PSDRUG(PSSIEN2,65,PSSALT,0)),U,1),0)),U,1)
- +6 SET PSSCNT=PSSCNT+1
- End DoDot:2
- End DoDot:1
- +7 IF PSSCNT=0
- SET ^TMP($JOB,LIST,PSSIEN2,"FRM",0)="-1^NO DATA FOUND"
- +8 IF '$TEST
- SET ^TMP($JOB,LIST,PSSIEN2,"FRM",0)=PSSCNT
- +9 QUIT
- +10 ;
- OLD ;FILLS THE OLD NAME MULTIPLE
- +1 SET PSSCNT=0
- +2 SET PSSOLD=0
- +3 FOR
- SET PSSOLD=$ORDER(^PSDRUG(PSSIEN2,900,PSSOLD))
- if PSSOLD=""
- QUIT
- Begin DoDot:1
- +4 IF $PIECE($GET(^PSDRUG(PSSIEN2,900,PSSOLD,0)),U,2)'=""
- Begin DoDot:2
- +5 SET PSSCAP=$$UP^XLFSTR($$FMTE^XLFDT($PIECE(^PSDRUG(PSSIEN2,900,PSSOLD,0),U,2)))
- +6 SET ^TMP($JOB,LIST,PSSIEN2,"OLD",PSSOLD,.02)=$PIECE($GET(^PSDRUG(PSSIEN2,900,PSSOLD,0)),U,2)_U_PSSCAP
- End DoDot:2
- +7 IF '$TEST
- SET ^TMP($JOB,LIST,PSSIEN2,"OLD",PSSOLD,.02)=""
- +8 IF $PIECE($GET(^PSDRUG(PSSIEN2,900,PSSOLD,0)),U,1)'=""
- Begin DoDot:2
- +9 SET ^TMP($JOB,LIST,PSSIEN2,"OLD",PSSOLD,.01)=$PIECE($GET(^PSDRUG(PSSIEN2,900,PSSOLD,0)),U,1)
- +10 SET PSSCNT=PSSCNT+1
- End DoDot:2
- +11 IF '$TEST
- SET ^TMP($JOB,LIST,PSSIEN2,"OLD",PSSOLD,.01)=""
- End DoDot:1
- +12 IF PSSCNT=0
- SET ^TMP($JOB,LIST,PSSIEN2,"OLD",0)="-1^NO DATA FOUND"
- +13 IF '$TEST
- SET ^TMP($JOB,LIST,PSSIEN2,"OLD",0)=PSSCNT
- +14 QUIT
- +15 ;
- SRVCODE(PSSMATCH) ;FILLS SERVICE CODE MULTIPLE
- +1 IF PSSMATCH'=""
- SET ^TMP($JOB,LIST,PSSIEN2,400)=$PIECE($GET(^PSNDF(50.68,PSSMATCH,"PFS")),U,1)
- +2 IF $PIECE($GET(^TMP($JOB,LIST,PSSIEN2,400)),U,1)=""
- SET ^TMP($JOB,LIST,PSSIEN2,400)=$PIECE($GET(^PSDRUG(PSSIEN2,"PFS")),U,1)
- +3 IF $PIECE($GET(^TMP($JOB,LIST,PSSIEN2,400)),U,1)=""
- SET ^TMP($JOB,LIST,PSSIEN2,400)=600000
- +4 QUIT
- +5 ;
- DRG ;
- +1 ;PSSIEN - IEN of entry in 50
- +2 ;PSSFT - Free Text name in 50
- +3 ;PSSFL - Inactive flag - "" - All entries
- +4 ; FileMan Date - Only entries with no Inactive Date or an Inactive Date greater than this date.
- +5 ;PSSPK - Application Package's Use - "" - All entries
- +6 ; Alphabetic codes that represent the DHCP packages that consider this drug to be
- +7 ; part of their formulary.
- +8 ;PSSRTOI - Orderable Item - return only entries matched to a Pharmacy Orderable Item
- +9 ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is the Field Number of the data
- +10 ; piece being returned.
- +11 NEW DIERR,ZZERR,PSSP50,SCR,PSS,PSSMLCT
- +12 IF $GET(LIST)']""
- QUIT
- +13 KILL ^TMP($JOB,LIST)
- +14 IF +$GET(PSSIEN)'>0
- IF ($GET(PSSFT)']"")
- SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
- QUIT
- +15 SET SCR("S")=""
- +16 IF +$GET(PSSFL)>0!($GET(PSSPK)]"")!($GET(PSSRTOI)=1)
- NEW PSS5ND,PSSZ3,PSSZ4
- DO SETSCRN^PSS50A
- +17 IF +$GET(PSSIEN)>0
- NEW PSSIEN2
- SET PSSIEN2=$$FIND1^DIC(50,"","A","`"_PSSIEN,,SCR("S"),"")
- Begin DoDot:1
- +18 KILL ^TMP("DIERR",$JOB)
- +19 IF +PSSIEN2'>0
- SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
- QUIT
- +20 SET ^TMP($JOB,LIST,0)=1
- +21 KILL ^TMP("PSSP50",$JOB)
- DO GETS^DIQ(50,+PSSIEN2,".01;62.01:62.05;905","IE","^TMP(""PSSP50"",$J)")
- SET PSS(1)=0
- +22 FOR
- SET PSS(1)=$ORDER(^TMP("PSSP50",$JOB,50,PSS(1)))
- if 'PSS(1)
- QUIT
- DO SETDRG^PSS50A1
- End DoDot:1
- KILL ^TMP("PSSP50",$JOB)
- QUIT
- +23 IF $GET(PSSIEN)'=""
- SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
- QUIT
- +24 IF $GET(PSSFT)]""
- Begin DoDot:1
- +25 IF PSSFT["??"
- DO LOOP^PSS50A1
- QUIT
- +26 KILL ^TMP("DILIST",$JOB)
- +27 DO FIND^DIC(50,,"@;.01","QP",PSSFT,,"B",SCR("S"),,"")
- +28 IF +$GET(^TMP("DILIST",$JOB,0))=0
- SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
- QUIT
- +29 IF +^TMP("DILIST",$JOB,0)>0
- SET ^TMP($JOB,LIST,0)=+^TMP("DILIST",$JOB,0)
- NEW PSSXX
- SET PSSXX=0
- FOR
- SET PSSXX=$ORDER(^TMP("DILIST",$JOB,PSSXX))
- if 'PSSXX
- QUIT
- Begin DoDot:2
- +30 SET PSSIEN=+^TMP("DILIST",$JOB,PSSXX,0)
- +31 KILL ^TMP("PSSP50",$JOB)
- DO GETS^DIQ(50,+PSSIEN,".01;62.01:62.05;905","IE","^TMP(""PSSP50"",$J)")
- SET PSS(1)=0
- +32 FOR
- SET PSS(1)=$ORDER(^TMP("PSSP50",$JOB,50,PSS(1)))
- if 'PSS(1)
- QUIT
- DO SETDRG^PSS50A1
- End DoDot:2
- End DoDot:1
- +33 KILL ^TMP("DILIST",$JOB),^TMP("PSSP50",$JOB)
- +34 QUIT
- +35 ;
- LOOP ;
- +1 NEW PSS50DD1,PSS50DD2,PSS50DD3,PSS50DD4,PSS50ER1,PSS50ER2,PSS50ER3,PSS50ER4,PSS51NFD,PSS52NFD,PSSG2N,PSS501NX
- +2 DO FIELD^DID(50,51,"Z","POINTER","PSS50DD1","PSS50ER1")
- SET PSS51NFD=$GET(PSS50DD1("POINTER"))
- +3 DO FIELD^DID(50,52,"Z","POINTER","PSS50DD2","PSS50ER2")
- SET PSS52NFD=$GET(PSS50DD2("POINTER"))
- +4 DO FIELD^DID(50,301,"Z","POINTER","PSS50DD3","PSS50ER3")
- SET PSSG2N=$GET(PSS50DD3("POINTER"))
- +5 DO FIELD^DID(50.1,1,"Z","POINTER","PSS50DD4","PSS50ER4")
- SET PSS501NX=$GET(PSS50DD4("POINTER"))
- +6 NEW PSSENCT
- +7 SET PSSENCT=0
- +8 SET PSS(1)=0
- FOR
- SET PSS(1)=$ORDER(^PSDRUG(PSS(1)))
- if 'PSS(1)
- QUIT
- Begin DoDot:1
- +9 IF $PIECE($GET(^PSDRUG(PSS(1),0)),"^")=""
- QUIT
- +10 IF $GET(PSSFL)
- IF $PIECE($GET(^PSDRUG(PSS(1),"I")),"^")
- IF $PIECE($GET(^("I")),"^")'>PSSFL
- QUIT
- +11 IF $GET(PSSRTOI)=1
- IF '$PIECE($GET(^PSDRUG(PSS(1),2)),"^")
- QUIT
- +12 ;Naked reference below refers to ^PSDRUG(PSS(1),2)
- +13 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
- +14 IF $GET(PSSPK)]""
- IF 'PSSZ5
- QUIT
- +15 DO SETSUB1^PSS50AQM(PSS(1))
- DO SETSUB2^PSS50AQM(PSS(1))
- DO SETSUB3^PSS50AQM(PSS(1))
- +16 DO SETALL^PSS50AQM
- DO SETOLD^PSS50AQM
- DO SETSYN^PSS50AQM
- DO SETFMA^PSS50AQM
- +17 SET PSSENCT=PSSENCT+1
- End DoDot:1
- +18 SET ^TMP($JOB,LIST,0)=$SELECT($GET(PSSENCT):$GET(PSSENCT),1:"-1^NO DATA FOUND")
- +19 QUIT