- PSS50F1 ;BIR/RTR - API FOR INFORMATION FROM FILE 50
- ;;1.0;PHARMACY DATA MANAGEMENT;**85**;9/30/97
- ;
- ;Reference to ^PS(50.605 is supported by DBIA #2138
- ;
- LIST ;
- ;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.
- ;PSSD - Index used in the lookup in the format B^C
- ;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,PSSP50,SCR,PSS,CNT,PSSXSUB,PSSLUPAR,PSSLUPP,PSSSCRN,PSSENCT
- I $G(LIST)']"" Q
- K ^TMP($J,LIST)
- I $G(PSSFT)']"" S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
- S SCR("S")=""
- S PSSXSUB="" D SETXSUB
- S PSSENCT=0
- I +$G(PSSFL)>0!($G(PSSPK)]"") N PSS5ND,PSSZ3,PSSZ4 D SETSCRN^PSS50A
- I $G(PSSFT)]"" D
- .I PSSFT["??" D LOOP Q
- .K ^TMP("DILIST",$J),^TMP($J,"PSSLDONE")
- .S PSSSCRN=$G(SCR("S")) S:$G(PSSD)="" PSSD="B" D PARSE^PSS50F(PSSD) I '$O(PSSLUPAR(0)) Q
- .S PSSLUPP=0 F S PSSLUPP=$O(PSSLUPAR(PSSLUPP)) Q:'PSSLUPP D
- ..S SCR("S")=$G(PSSSCRN)
- ..D FIND^DIC(50,,"@;.01","QPB"_$S($P(PSSLUPAR(PSSLUPP),"^",2):"X",1:""),PSSFT,,PSSLUPAR(PSSLUPP),SCR("S"),,"")
- ..I +$G(^TMP("DILIST",$J,0))=0 Q
- ..I +^TMP("DILIST",$J,0)>0 N PSSXX S PSSXX=0 F S PSSXX=$O(^TMP("DILIST",$J,PSSXX)) Q:'PSSXX D
- ...S PSSIEN=+^TMP("DILIST",$J,PSSXX,0) I '$D(^TMP($J,"PSSLDONE",PSSIEN)) S ^TMP($J,"PSSLDONE",PSSIEN)="" D
- ....K ^TMP("PSSP50",$J) D GETS^DIQ(50,+PSSIEN,".01;100;2.1","IE","^TMP(""PSSP50"",$J)") S PSS(1)=0
- ....F S PSS(1)=$O(^TMP("PSSP50",$J,50,PSS(1))) Q:'PSS(1) D SETLIST
- S ^TMP($J,LIST,0)=$S($G(PSSENCT):$G(PSSENCT),1:"-1^NO DATA FOUND")
- K ^TMP("DILIST",$J),^TMP("PSSP50",$J),^TMP($J,"PSSLDONE")
- Q
- SETLIST ;
- S PSSENCT=PSSENCT+1
- S ^TMP($J,LIST,+PSS(1),.01)=$G(^TMP("PSSP50",$J,50,PSS(1),.01,"I"))
- ;S ^TMP($J,LIST,"B",$G(^TMP("PSSP50",$J,50,PSS(1),.01,"I")),+PSS(1))=""
- ;S ^TMP($J,LIST,$S($G(PSSD)]"":$P(PSSD,"^"),1:"B"),^TMP("PSSP50",$J,50,PSS(1),.01,"I"),+PSS(1))=""
- S ^TMP($J,LIST,$S($G(PSSXSUB)'="":$G(PSSXSUB),1:"B"),^TMP("PSSP50",$J,50,PSS(1),.01,"I"),+PSS(1))=""
- S ^TMP($J,LIST,+PSS(1),2.1)=$S($G(^TMP("PSSP50",$J,50,PSS(1),2.1,"I"))="":"",1:$G(^TMP("PSSP50",$J,50,PSS(1),2.1,"I"))_"^"_$G(^TMP("PSSP50",$J,50,PSS(1),2.1,"E")))
- I $P($G(^TMP($J,LIST,+PSS(1),2.1)),"^") D
- .N PSSADDF S PSSADDF=$$SETDF^PSS50AQM($P(^TMP($J,LIST,+PSS(1),2.1),"^")) S ^TMP($J,LIST,+PSS(1),2.1)=^TMP($J,LIST,+PSS(1),2.1)_$S($P($G(PSSADDF),"^")>0:"^"_$P($G(PSSADDF),"^",3)_"^"_$P($G(PSSADDF),"^",4),1:"")
- S ^TMP($J,LIST,+PSS(1),100)=$S($G(^TMP("PSSP50",$J,50,PSS(1),100,"I"))="":"",1:$G(^TMP("PSSP50",$J,50,PSS(1),100,"I"))_"^"_$G(^TMP("PSSP50",$J,50,PSS(1),100,"E")))
- Q
- LOOP ;
- 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 SETLISTL
- .S PSSENCT=PSSENCT+1
- Q
- SETLISTL ;
- N PSSZNODE,PSS2NODE S PSSZNODE=$G(^PSDRUG(PSS(1),0)),PSS2NODE=$G(^(2))
- S ^TMP($J,LIST,+PSS(1),.01)=$P(PSSZNODE,"^")
- S ^TMP($J,LIST,"B",$P(PSSZNODE,"^"),+PSS(1))=""
- S ^TMP($J,LIST,+PSS(1),2.1)=$S('$P(PSS2NODE,"^"):"",1:$P(PSS2NODE,"^")_"^"_$P($G(^PS(50.7,+$P(PSS2NODE,"^"),0)),"^"))
- N PSSADDF S PSSADDF=$P($G(^PS(50.7,+$P($G(^TMP($J,LIST,+PSS(1),2.1)),"^"),0)),"^",2) I PSSADDF>0 D
- .S ^TMP($J,LIST,+PSS(1),2.1)=^TMP($J,LIST,+PSS(1),2.1)_"^"_PSSADDF_"^"_$P($G(^PS(50.606,PSSADDF,0)),"^")
- N Y S Y=$P($G(^PSDRUG(PSS(1),"I")),"^") D
- .I Y S ^TMP($J,LIST,+PSS(1),100)=$G(Y) X ^DD("DD") S ^TMP($J,LIST,+PSS(1),100)=^TMP($J,LIST,+PSS(1),100)_"^"_$G(Y) Q
- .S ^TMP($J,LIST,+PSS(1),100)=""
- Q
- SETXSUB ;
- Q:$G(PSSD)=""
- N PSSLSX,PSSLSXCT,PSSLCNT,PSSDSUB
- S PSSLSXCT=0
- F PSSLSX=1:1:$L(PSSD) I $E(PSSD,PSSLSX)="^" S PSSLSXCT=PSSLSXCT+1
- S PSSLSXCT=PSSLSXCT+1
- S PSSLCNT=0 F PSSLSX=1:1:PSSLSXCT S PSSDSUB=$P(PSSD,"^",PSSLSX) Q:PSSLCNT>1 S PSSXSUB=$S(PSSDSUB'="":PSSDSUB,PSSXSUB'="":PSSXSUB,1:"") S:PSSDSUB'="" PSSLCNT=PSSLCNT+1
- I PSSLCNT>1 S PSSXSUB=""
- Q
- LOOKUP ;
- ;PSSFT - Free Text value that could be the NAME field (#.01), IEN, VA PRODUCT NAME field (#21), NATIONAL DRUG CLASS field (#25),
- ; or SYNONYM (#.01) mutiple 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.
- ;PSSRTOI - 1 - only drugs with data in the PHARMACY ORDERABLE ITEM field (#2.1) will be returned.
- ;PSSIFCAP - 1 - only drugs with no data in the IFCAP ITEM NUMBER multiple (#441) will be returned.
- ;PSSCMOP - 1 - only drugs with no data in the CMOP ID field (#27) will be returned.
- ;PSSD - Index used in the lookup in the format B^C.
- ;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 PSSLKIEN,PSSLKSUB,PSSENCT,SCR,PSSXSUB,CNT,PSS,DIERR
- I $G(LIST)']"" Q
- K ^TMP($J,LIST)
- I $G(PSSFT)']"" S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
- S PSSENCT=0
- I PSSFT["??" D LOOPLK Q
- S SCR("S")=""
- I $G(PSSCMOP)=1 D
- .S SCR("S")="I $P($G(^(""ND"")),""^"",10)=""""" Q
- I $G(PSSIFCAP)=1 D
- .I SCR("S")="" S SCR("S")="I '$O(^PSDRUG(+Y,441,0))" Q
- .S SCR("S")=SCR("S")_" I '$O(^PSDRUG(+Y,441,0))"
- I +$G(PSSFL)>0!($G(PSSPK)]"")!($G(PSSRTOI)=1) N PSS5ND,PSSZ3,PSSZ4 D SETSCRN
- I PSSFT'="",PSSFT?1"`"1N.N D S ^TMP($J,LIST,0)=$S($G(PSSENCT):$G(PSSENCT),1:"-1^NO DATA FOUND") Q
- .N PSSIEN2 S PSSIEN2=$$FIND1^DIC(50,"","A",PSSFT,,SCR("S"),"")
- .K ^TMP("DIERR",$J)
- .I +PSSIEN2'>0 Q
- .I $P($G(^PSDRUG(+PSSIEN2,0)),"^")="" Q
- .S PSSLKIEN=+PSSIEN2,PSSLKSUB="B"
- .D LOOKSET
- I $G(PSSFT)]"" D
- .N PSSLUPAR,PSSLUPP,PSSSCRN
- .S PSSXSUB="" D SETXSUB S PSSLKSUB=$S($G(PSSXSUB)'="":$G(PSSXSUB),1:"B")
- .K ^TMP("DILIST",$J),^TMP($J,"PSSLDONE")
- .S PSSSCRN=$G(SCR("S")) S:$G(PSSD)="" PSSD="B" D PARSE^PSS50F(PSSD) I '$O(PSSLUPAR(0)) Q
- .S PSSLUPP=0 F S PSSLUPP=$O(PSSLUPAR(PSSLUPP)) Q:'PSSLUPP D
- ..S SCR("S")=PSSSCRN
- ..D FIND^DIC(50,,"@;.01","QPB"_$S($P(PSSLUPAR(PSSLUPP),"^",2):"X",1:""),PSSFT,,PSSLUPAR(PSSLUPP),SCR("S"),,"")
- ..I +$G(^TMP("DILIST",$J,0))=0 Q
- ..I +^TMP("DILIST",$J,0)>0 N PSSXX S PSSXX=0 F S PSSXX=$O(^TMP("DILIST",$J,PSSXX)) Q:'PSSXX D
- ...S PSSLKIEN=+^TMP("DILIST",$J,PSSXX,0) I $P($G(^PSDRUG(PSSLKIEN,0)),"^")'="",'$D(^TMP($J,"PSSLDONE",PSSLKIEN)) S ^TMP($J,"PSSLDONE",PSSLKIEN)="" D LOOKSET
- S ^TMP($J,LIST,0)=$S($G(PSSENCT):$G(PSSENCT),1:"-1^NO DATA FOUND")
- K ^TMP("DILIST",$J),^TMP($J,"PSSLDONE")
- Q
- LOOKSET ;
- ;PSSLKIEN = ien from File 50
- ;PSSLKSUB = Subscript for the cross reference return
- N PSSLKNAM,PSSLKND,PSSLKZER
- S PSSLKNAM=$P($G(^PSDRUG(PSSLKIEN,0)),"^"),PSSLKND=$G(^("ND")),PSSLKZER=$G(^(0)) Q:PSSLKNAM=""
- S ^TMP($J,LIST,PSSLKIEN,.01)=PSSLKNAM
- S ^TMP($J,LIST,PSSLKSUB,PSSLKNAM,PSSLKIEN)=""
- S PSSENCT=PSSENCT+1
- S ^TMP($J,LIST,PSSLKIEN,25)=$S($P(PSSLKND,"^",6):$P(PSSLKND,"^",6)_"^"_$P($G(^PS(50.605,+$P(PSSLKND,"^",6),0)),"^")_"^"_$P($G(^(0)),"^",2),1:"")
- N Y S Y=$P($G(^PSDRUG(PSSLKIEN,"I")),"^") D
- .I Y S ^TMP($J,LIST,PSSLKIEN,100)=$G(Y) X ^DD("DD") S ^TMP($J,LIST,PSSLKIEN,100)=^TMP($J,LIST,PSSLKIEN,100)_"^"_$G(Y) Q
- .S ^TMP($J,LIST,PSSLKIEN,100)=""
- S ^TMP($J,LIST,PSSLKIEN,101)=$P(PSSLKZER,"^",10)
- Q
- LOOPLK ;
- S PSSLKSUB="B"
- S PSSLKIEN=0 F S PSSLKIEN=$O(^PSDRUG(PSSLKIEN)) Q:'PSSLKIEN D
- .I $P($G(^PSDRUG(PSSLKIEN,0)),"^")="" Q
- .I $G(PSSCMOP)=1,$P($G(^PSDRUG(PSSLKIEN,"ND")),"^",10)'="" Q
- .I $G(PSSIFCAP)=1,$O(^PSDRUG(PSSLKIEN,441,0)) Q
- .I $G(PSSFL),$P($G(^PSDRUG(PSSLKIEN,"I")),"^"),$P($G(^("I")),"^")'>PSSFL Q
- .I $G(PSSRTOI)=1,'$P($G(^PSDRUG(PSSLKIEN,2)),"^") Q
- .I $G(PSSPK)]"" N PSSZ5,PSSZ6 S PSSZ5=0 F PSSZ6=1:1:$L(PSSPK) Q:PSSZ5 I $P($G(^PSDRUG(PSSLKIEN,2)),"^",3)[$E(PSSPK,PSSZ6) S PSSZ5=1
- .I $G(PSSPK)]"",'PSSZ5 Q
- .D LOOKSET
- S ^TMP($J,LIST,0)=$S($G(PSSENCT):$G(PSSENCT),1:"-1^NO DATA FOUND")
- Q
- ;
- SETSCRN ;Set Screen
- I +$G(PSSFL)>0 D
- .I SCR("S")]"" S SCR("S")=SCR("S")_" S PSS5ND=$P($G(^PSDRUG(+Y,""I"")),""^"") I PSS5ND=""""!(PSS5ND>PSSFL)" Q
- .S SCR("S")="S PSS5ND=$P($G(^PSDRUG(+Y,""I"")),""^"") I PSS5ND=""""!(PSS5ND>PSSFL)"
- I $G(PSSRTOI)=1 D
- .I SCR("S")]"" S SCR("S")=SCR("S")_" I $P($G(^PSDRUG(+Y,2)),""^"")" Q
- .S SCR("S")="I $P($G(^PSDRUG(+Y,2)),""^"")"
- I $G(PSSPK)]"" D
- .I SCR("S")]"" S SCR("S")=SCR("S")_" S PSSZ3=0 F PSSZ4=1:1:$L(PSSPK) Q:PSSZ3 I $P($G(^PSDRUG(+Y,2)),""^"",3)[$E(PSSPK,PSSZ4) S PSSZ3=1" Q
- .S SCR("S")="S PSSZ3=0 F PSSZ4=1:1:$L(PSSPK) Q:PSSZ3 I $P($G(^PSDRUG(+Y,2)),""^"",3)[$E(PSSPK,PSSZ4) S PSSZ3=1"
- ;I $G(PSSPK)]"" S SCR("S")=$S(SCR("S")]"":SCR("S")_" I $G(^PSDRUG(+Y,2)),$P($G(^PSDRUG(+Y,2)),""^"",3)[PSSPK",1:"I $G(^PSDRUG(+Y,2)),$P($G(^PSDRUG(+Y,2)),""^"",3)[PSSPK")
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSS50F1 9555 printed Mar 13, 2025@21:34:23 Page 2
- PSS50F1 ;BIR/RTR - API FOR INFORMATION FROM FILE 50
- +1 ;;1.0;PHARMACY DATA MANAGEMENT;**85**;9/30/97
- +2 ;
- +3 ;Reference to ^PS(50.605 is supported by DBIA #2138
- +4 ;
- LIST ;
- +1 ;PSSFT - Free Text name in 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 ;PSSD - Index used in the lookup in the format B^C
- +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 ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is the Field Number of the data
- +9 ; piece being returned.
- +10 NEW DIERR,ZZERR,PSSP50,SCR,PSS,CNT,PSSXSUB,PSSLUPAR,PSSLUPP,PSSSCRN,PSSENCT
- +11 IF $GET(LIST)']""
- QUIT
- +12 KILL ^TMP($JOB,LIST)
- +13 IF $GET(PSSFT)']""
- SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
- QUIT
- +14 SET SCR("S")=""
- +15 SET PSSXSUB=""
- DO SETXSUB
- +16 SET PSSENCT=0
- +17 IF +$GET(PSSFL)>0!($GET(PSSPK)]"")
- NEW PSS5ND,PSSZ3,PSSZ4
- DO SETSCRN^PSS50A
- +18 IF $GET(PSSFT)]""
- Begin DoDot:1
- +19 IF PSSFT["??"
- DO LOOP
- QUIT
- +20 KILL ^TMP("DILIST",$JOB),^TMP($JOB,"PSSLDONE")
- +21 SET PSSSCRN=$GET(SCR("S"))
- if $GET(PSSD)=""
- SET PSSD="B"
- DO PARSE^PSS50F(PSSD)
- IF '$ORDER(PSSLUPAR(0))
- QUIT
- +22 SET PSSLUPP=0
- FOR
- SET PSSLUPP=$ORDER(PSSLUPAR(PSSLUPP))
- if 'PSSLUPP
- QUIT
- Begin DoDot:2
- +23 SET SCR("S")=$GET(PSSSCRN)
- +24 DO FIND^DIC(50,,"@;.01","QPB"_$SELECT($PIECE(PSSLUPAR(PSSLUPP),"^",2):"X",1:""),PSSFT,,PSSLUPAR(PSSLUPP),SCR("S"),,"")
- +25 IF +$GET(^TMP("DILIST",$JOB,0))=0
- QUIT
- +26 IF +^TMP("DILIST",$JOB,0)>0
- NEW PSSXX
- SET PSSXX=0
- FOR
- SET PSSXX=$ORDER(^TMP("DILIST",$JOB,PSSXX))
- if 'PSSXX
- QUIT
- Begin DoDot:3
- +27 SET PSSIEN=+^TMP("DILIST",$JOB,PSSXX,0)
- IF '$DATA(^TMP($JOB,"PSSLDONE",PSSIEN))
- SET ^TMP($JOB,"PSSLDONE",PSSIEN)=""
- Begin DoDot:4
- +28 KILL ^TMP("PSSP50",$JOB)
- DO GETS^DIQ(50,+PSSIEN,".01;100;2.1","IE","^TMP(""PSSP50"",$J)")
- SET PSS(1)=0
- +29 FOR
- SET PSS(1)=$ORDER(^TMP("PSSP50",$JOB,50,PSS(1)))
- if 'PSS(1)
- QUIT
- DO SETLIST
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +30 SET ^TMP($JOB,LIST,0)=$SELECT($GET(PSSENCT):$GET(PSSENCT),1:"-1^NO DATA FOUND")
- +31 KILL ^TMP("DILIST",$JOB),^TMP("PSSP50",$JOB),^TMP($JOB,"PSSLDONE")
- +32 QUIT
- SETLIST ;
- +1 SET PSSENCT=PSSENCT+1
- +2 SET ^TMP($JOB,LIST,+PSS(1),.01)=$GET(^TMP("PSSP50",$JOB,50,PSS(1),.01,"I"))
- +3 ;S ^TMP($J,LIST,"B",$G(^TMP("PSSP50",$J,50,PSS(1),.01,"I")),+PSS(1))=""
- +4 ;S ^TMP($J,LIST,$S($G(PSSD)]"":$P(PSSD,"^"),1:"B"),^TMP("PSSP50",$J,50,PSS(1),.01,"I"),+PSS(1))=""
- +5 SET ^TMP($JOB,LIST,$SELECT($GET(PSSXSUB)'="":$GET(PSSXSUB),1:"B"),^TMP("PSSP50",$JOB,50,PSS(1),.01,"I"),+PSS(1))=""
- +6 SET ^TMP($JOB,LIST,+PSS(1),2.1)=$SELECT($GET(^TMP("PSSP50",$JOB,50,PSS(1),2.1,"I"))="":"",1:$GET(^TMP("PSSP50",$JOB,50,PSS(1),2.1,"I"))_"^"_$GET(^TMP("PSSP50",$JOB,50,PSS(1),2.1,"E")))
- +7 IF $PIECE($GET(^TMP($JOB,LIST,+PSS(1),2.1)),"^")
- Begin DoDot:1
- +8 NEW PSSADDF
- SET PSSADDF=$$SETDF^PSS50AQM($PIECE(^TMP($JOB,LIST,+PSS(1),2.1),"^"))
- SET ^TMP($JOB,LIST,+PSS(1),2.1)=^TMP($JOB,LIST,+PSS(1),2.1)_$SELECT($PIECE($GET(PSSADDF),"^")>0:"^"_$PIECE($GET(PSSADDF),"^",3)_"^"_$PIECE($GET(PSSADDF),"^",4),1:"")
- End DoDot:1
- +9 SET ^TMP($JOB,LIST,+PSS(1),100)=$SELECT($GET(^TMP("PSSP50",$JOB,50,PSS(1),100,"I"))="":"",1:$GET(^TMP("PSSP50",$JOB,50,PSS(1),100,"I"))_"^"_$GET(^TMP("PSSP50",$JOB,50,PSS(1),100,"E")))
- +10 QUIT
- LOOP ;
- +1 SET PSS(1)=0
- FOR
- SET PSS(1)=$ORDER(^PSDRUG(PSS(1)))
- if 'PSS(1)
- QUIT
- Begin DoDot:1
- +2 IF $PIECE($GET(^PSDRUG(PSS(1),0)),"^")=""
- QUIT
- +3 IF $GET(PSSFL)
- IF $PIECE($GET(^PSDRUG(PSS(1),"I")),"^")
- IF $PIECE($GET(^("I")),"^")'>PSSFL
- QUIT
- +4 ;I $G(PSSRTOI)=1,'$P($G(^PSDRUG(PSS(1),2)),"^") Q
- +5 ;Naked reference below refers to ^PSDRUG(PSS(1),2)
- +6 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
- +7 IF $GET(PSSPK)]""
- IF 'PSSZ5
- QUIT
- +8 DO SETLISTL
- +9 SET PSSENCT=PSSENCT+1
- End DoDot:1
- +10 QUIT
- SETLISTL ;
- +1 NEW PSSZNODE,PSS2NODE
- SET PSSZNODE=$GET(^PSDRUG(PSS(1),0))
- SET PSS2NODE=$GET(^(2))
- +2 SET ^TMP($JOB,LIST,+PSS(1),.01)=$PIECE(PSSZNODE,"^")
- +3 SET ^TMP($JOB,LIST,"B",$PIECE(PSSZNODE,"^"),+PSS(1))=""
- +4 SET ^TMP($JOB,LIST,+PSS(1),2.1)=$SELECT('$PIECE(PSS2NODE,"^"):"",1:$PIECE(PSS2NODE,"^")_"^"_$PIECE($GET(^PS(50.7,+$PIECE(PSS2NODE,"^"),0)),"^"))
- +5 NEW PSSADDF
- SET PSSADDF=$PIECE($GET(^PS(50.7,+$PIECE($GET(^TMP($JOB,LIST,+PSS(1),2.1)),"^"),0)),"^",2)
- IF PSSADDF>0
- Begin DoDot:1
- +6 SET ^TMP($JOB,LIST,+PSS(1),2.1)=^TMP($JOB,LIST,+PSS(1),2.1)_"^"_PSSADDF_"^"_$PIECE($GET(^PS(50.606,PSSADDF,0)),"^")
- End DoDot:1
- +7 NEW Y
- SET Y=$PIECE($GET(^PSDRUG(PSS(1),"I")),"^")
- Begin DoDot:1
- +8 IF Y
- SET ^TMP($JOB,LIST,+PSS(1),100)=$GET(Y)
- XECUTE ^DD("DD")
- SET ^TMP($JOB,LIST,+PSS(1),100)=^TMP($JOB,LIST,+PSS(1),100)_"^"_$GET(Y)
- QUIT
- +9 SET ^TMP($JOB,LIST,+PSS(1),100)=""
- End DoDot:1
- +10 QUIT
- SETXSUB ;
- +1 if $GET(PSSD)=""
- QUIT
- +2 NEW PSSLSX,PSSLSXCT,PSSLCNT,PSSDSUB
- +3 SET PSSLSXCT=0
- +4 FOR PSSLSX=1:1:$LENGTH(PSSD)
- IF $EXTRACT(PSSD,PSSLSX)="^"
- SET PSSLSXCT=PSSLSXCT+1
- +5 SET PSSLSXCT=PSSLSXCT+1
- +6 SET PSSLCNT=0
- FOR PSSLSX=1:1:PSSLSXCT
- SET PSSDSUB=$PIECE(PSSD,"^",PSSLSX)
- if PSSLCNT>1
- QUIT
- SET PSSXSUB=$SELECT(PSSDSUB'="":PSSDSUB,PSSXSUB'="":PSSXSUB,1:"")
- if PSSDSUB'=""
- SET PSSLCNT=PSSLCNT+1
- +7 IF PSSLCNT>1
- SET PSSXSUB=""
- +8 QUIT
- LOOKUP ;
- +1 ;PSSFT - Free Text value that could be the NAME field (#.01), IEN, VA PRODUCT NAME field (#21), NATIONAL DRUG CLASS field (#25),
- +2 ; or SYNONYM (#.01) mutiple of the DRUG file (#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 - 1 - only drugs with data in the PHARMACY ORDERABLE ITEM field (#2.1) will be returned.
- +9 ;PSSIFCAP - 1 - only drugs with no data in the IFCAP ITEM NUMBER multiple (#441) will be returned.
- +10 ;PSSCMOP - 1 - only drugs with no data in the CMOP ID field (#27) will be returned.
- +11 ;PSSD - Index used in the lookup in the format B^C.
- +12 ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is the Field Number of the data
- +13 ; piece being returned.
- +14 NEW PSSLKIEN,PSSLKSUB,PSSENCT,SCR,PSSXSUB,CNT,PSS,DIERR
- +15 IF $GET(LIST)']""
- QUIT
- +16 KILL ^TMP($JOB,LIST)
- +17 IF $GET(PSSFT)']""
- SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
- QUIT
- +18 SET PSSENCT=0
- +19 IF PSSFT["??"
- DO LOOPLK
- QUIT
- +20 SET SCR("S")=""
- +21 IF $GET(PSSCMOP)=1
- Begin DoDot:1
- +22 SET SCR("S")="I $P($G(^(""ND"")),""^"",10)="""""
- QUIT
- End DoDot:1
- +23 IF $GET(PSSIFCAP)=1
- Begin DoDot:1
- +24 IF SCR("S")=""
- SET SCR("S")="I '$O(^PSDRUG(+Y,441,0))"
- QUIT
- +25 SET SCR("S")=SCR("S")_" I '$O(^PSDRUG(+Y,441,0))"
- End DoDot:1
- +26 IF +$GET(PSSFL)>0!($GET(PSSPK)]"")!($GET(PSSRTOI)=1)
- NEW PSS5ND,PSSZ3,PSSZ4
- DO SETSCRN
- +27 IF PSSFT'=""
- IF PSSFT?1"`"1N.N
- Begin DoDot:1
- +28 NEW PSSIEN2
- SET PSSIEN2=$$FIND1^DIC(50,"","A",PSSFT,,SCR("S"),"")
- +29 KILL ^TMP("DIERR",$JOB)
- +30 IF +PSSIEN2'>0
- QUIT
- +31 IF $PIECE($GET(^PSDRUG(+PSSIEN2,0)),"^")=""
- QUIT
- +32 SET PSSLKIEN=+PSSIEN2
- SET PSSLKSUB="B"
- +33 DO LOOKSET
- End DoDot:1
- SET ^TMP($JOB,LIST,0)=$SELECT($GET(PSSENCT):$GET(PSSENCT),1:"-1^NO DATA FOUND")
- QUIT
- +34 IF $GET(PSSFT)]""
- Begin DoDot:1
- +35 NEW PSSLUPAR,PSSLUPP,PSSSCRN
- +36 SET PSSXSUB=""
- DO SETXSUB
- SET PSSLKSUB=$SELECT($GET(PSSXSUB)'="":$GET(PSSXSUB),1:"B")
- +37 KILL ^TMP("DILIST",$JOB),^TMP($JOB,"PSSLDONE")
- +38 SET PSSSCRN=$GET(SCR("S"))
- if $GET(PSSD)=""
- SET PSSD="B"
- DO PARSE^PSS50F(PSSD)
- IF '$ORDER(PSSLUPAR(0))
- QUIT
- +39 SET PSSLUPP=0
- FOR
- SET PSSLUPP=$ORDER(PSSLUPAR(PSSLUPP))
- if 'PSSLUPP
- QUIT
- Begin DoDot:2
- +40 SET SCR("S")=PSSSCRN
- +41 DO FIND^DIC(50,,"@;.01","QPB"_$SELECT($PIECE(PSSLUPAR(PSSLUPP),"^",2):"X",1:""),PSSFT,,PSSLUPAR(PSSLUPP),SCR("S"),,"")
- +42 IF +$GET(^TMP("DILIST",$JOB,0))=0
- QUIT
- +43 IF +^TMP("DILIST",$JOB,0)>0
- NEW PSSXX
- SET PSSXX=0
- FOR
- SET PSSXX=$ORDER(^TMP("DILIST",$JOB,PSSXX))
- if 'PSSXX
- QUIT
- Begin DoDot:3
- +44 SET PSSLKIEN=+^TMP("DILIST",$JOB,PSSXX,0)
- IF $PIECE($GET(^PSDRUG(PSSLKIEN,0)),"^")'=""
- IF '$DATA(^TMP($JOB,"PSSLDONE",PSSLKIEN))
- SET ^TMP($JOB,"PSSLDONE",PSSLKIEN)=""
- DO LOOKSET
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +45 SET ^TMP($JOB,LIST,0)=$SELECT($GET(PSSENCT):$GET(PSSENCT),1:"-1^NO DATA FOUND")
- +46 KILL ^TMP("DILIST",$JOB),^TMP($JOB,"PSSLDONE")
- +47 QUIT
- LOOKSET ;
- +1 ;PSSLKIEN = ien from File 50
- +2 ;PSSLKSUB = Subscript for the cross reference return
- +3 NEW PSSLKNAM,PSSLKND,PSSLKZER
- +4 SET PSSLKNAM=$PIECE($GET(^PSDRUG(PSSLKIEN,0)),"^")
- SET PSSLKND=$GET(^("ND"))
- SET PSSLKZER=$GET(^(0))
- if PSSLKNAM=""
- QUIT
- +5 SET ^TMP($JOB,LIST,PSSLKIEN,.01)=PSSLKNAM
- +6 SET ^TMP($JOB,LIST,PSSLKSUB,PSSLKNAM,PSSLKIEN)=""
- +7 SET PSSENCT=PSSENCT+1
- +8 SET ^TMP($JOB,LIST,PSSLKIEN,25)=$SELECT($PIECE(PSSLKND,"^",6):$PIECE(PSSLKND,"^",6)_"^"_$PIECE($GET(^PS(50.605,+$PIECE(PSSLKND,"^",6),0)),"^")_"^"_$PIECE($GET(^(0)),"^",2),1:"")
- +9 NEW Y
- SET Y=$PIECE($GET(^PSDRUG(PSSLKIEN,"I")),"^")
- Begin DoDot:1
- +10 IF Y
- SET ^TMP($JOB,LIST,PSSLKIEN,100)=$GET(Y)
- XECUTE ^DD("DD")
- SET ^TMP($JOB,LIST,PSSLKIEN,100)=^TMP($JOB,LIST,PSSLKIEN,100)_"^"_$GET(Y)
- QUIT
- +11 SET ^TMP($JOB,LIST,PSSLKIEN,100)=""
- End DoDot:1
- +12 SET ^TMP($JOB,LIST,PSSLKIEN,101)=$PIECE(PSSLKZER,"^",10)
- +13 QUIT
- LOOPLK ;
- +1 SET PSSLKSUB="B"
- +2 SET PSSLKIEN=0
- FOR
- SET PSSLKIEN=$ORDER(^PSDRUG(PSSLKIEN))
- if 'PSSLKIEN
- QUIT
- Begin DoDot:1
- +3 IF $PIECE($GET(^PSDRUG(PSSLKIEN,0)),"^")=""
- QUIT
- +4 IF $GET(PSSCMOP)=1
- IF $PIECE($GET(^PSDRUG(PSSLKIEN,"ND")),"^",10)'=""
- QUIT
- +5 IF $GET(PSSIFCAP)=1
- IF $ORDER(^PSDRUG(PSSLKIEN,441,0))
- QUIT
- +6 IF $GET(PSSFL)
- IF $PIECE($GET(^PSDRUG(PSSLKIEN,"I")),"^")
- IF $PIECE($GET(^("I")),"^")'>PSSFL
- QUIT
- +7 IF $GET(PSSRTOI)=1
- IF '$PIECE($GET(^PSDRUG(PSSLKIEN,2)),"^")
- QUIT
- +8 IF $GET(PSSPK)]""
- NEW PSSZ5,PSSZ6
- SET PSSZ5=0
- FOR PSSZ6=1:1:$LENGTH(PSSPK)
- if PSSZ5
- QUIT
- IF $PIECE($GET(^PSDRUG(PSSLKIEN,2)),"^",3)[$EXTRACT(PSSPK,PSSZ6)
- SET PSSZ5=1
- +9 IF $GET(PSSPK)]""
- IF 'PSSZ5
- QUIT
- +10 DO LOOKSET
- End DoDot:1
- +11 SET ^TMP($JOB,LIST,0)=$SELECT($GET(PSSENCT):$GET(PSSENCT),1:"-1^NO DATA FOUND")
- +12 QUIT
- +13 ;
- SETSCRN ;Set Screen
- +1 IF +$GET(PSSFL)>0
- Begin DoDot:1
- +2 IF SCR("S")]""
- SET SCR("S")=SCR("S")_" S PSS5ND=$P($G(^PSDRUG(+Y,""I"")),""^"") I PSS5ND=""""!(PSS5ND>PSSFL)"
- QUIT
- +3 SET SCR("S")="S PSS5ND=$P($G(^PSDRUG(+Y,""I"")),""^"") I PSS5ND=""""!(PSS5ND>PSSFL)"
- End DoDot:1
- +4 IF $GET(PSSRTOI)=1
- Begin DoDot:1
- +5 IF SCR("S")]""
- SET SCR("S")=SCR("S")_" I $P($G(^PSDRUG(+Y,2)),""^"")"
- QUIT
- +6 SET SCR("S")="I $P($G(^PSDRUG(+Y,2)),""^"")"
- End DoDot:1
- +7 IF $GET(PSSPK)]""
- Begin DoDot:1
- +8 IF SCR("S")]""
- SET SCR("S")=SCR("S")_" S PSSZ3=0 F PSSZ4=1:1:$L(PSSPK) Q:PSSZ3 I $P($G(^PSDRUG(+Y,2)),""^"",3)[$E(PSSPK,PSSZ4) S PSSZ3=1"
- QUIT
- +9 SET SCR("S")="S PSSZ3=0 F PSSZ4=1:1:$L(PSSPK) Q:PSSZ3 I $P($G(^PSDRUG(+Y,2)),""^"",3)[$E(PSSPK,PSSZ4) S PSSZ3=1"
- End DoDot:1
- +10 ;I $G(PSSPK)]"" S SCR("S")=$S(SCR("S")]"":SCR("S")_" I $G(^PSDRUG(+Y,2)),$P($G(^PSDRUG(+Y,2)),""^"",3)[PSSPK",1:"I $G(^PSDRUG(+Y,2)),$P($G(^PSDRUG(+Y,2)),""^"",3)[PSSPK")
- +11 QUIT
