- PSNHIT ;BIR/CCH&WRT-After match is made package size and type selected ; 02/08/00 8:41
- ;;4.0;NATIONAL DRUG FILE;**22,47,65,492,396**; 30 Oct 98;Build 190
- ;
- ;Reference to ^DIC(51.5 supported by DBIA #1931
- ;Reference to ^PSDRUG supported by DBIA #2352,#221
- ;
- S ASC="Enter your choice or press return to continue: "
- HIT W !!,"Match made with ",PSNLOC W:$P(^PSDRUG(PSNB,0),"^",9)=1 ?62,"N/F" W !," Now select VA Product Name ",!
- S PSNFL=0
- FORM K ANS,LIST,DA S DA=PSNDA,X=$$VAP^PSNAPIS(DA,.LIST),STOP=X D STAR0,STAR F PSNWR=0:0 S PSNWR=$O(^TMP($J,"PSNND",PSNWR)) Q:'PSNWR
- WRTIT F BB=1:1:STOP D EXTD D I BB#10=0,STOP'=10 W !!,ASC R ANS:DTIME S:'$T ANS="^" S:ANS="^" PSNFL=1 Q:PSNFL Q:ANS]""
- .W !,BB," ",$P(^TMP($J,"PSNND",BB),"^",1)_" "_$P(^TMP($J,"PSNND",BB),"^",3)_" "_$P(^TMP($J,"PSNND",BB),"^",4)_" "_CMID_" "_$S($P(^TMP($J,"PSNND",BB),"^",6)="I":"**INACTIVE**",1:"")
- .W " "_$$GET1^DIQ(50.68,$P(^TMP($J,"PSNND",BB),"^",2),109) ;PPSN
- .W " "_$P(^TMP($J,"PSNND",BB),"^",7) ; PSN*4*492 FMCT
- I $D(ANS),ANS?.E1C.E G FORM
- I $D(ANS),ANS["?" D HIT1^PSNHELP K ANS G FORM
- Q:PSNFL I $D(ANS),ANS']"" K ANS
- I $D(ANS),ANS?.E1C.E G FORM
- VAPN I '$D(ANS) S:$D(XRT0) XRTN=$T(+0) D:$D(XRT0) T1^%ZOSV R !!,"Enter your choice: ",ANS:DTIME S:'$T ANS="^" S:ANS["^" PSNFL=1 Q:PSNFL
- I ANS?.E1C.E K ANS G VAPN
- I $D(ANS),ANS["?" D NDC3^PSNHELP W !!,"Match local drug ",PSNNAM," with " W !,?40,"ORDER UNIT: " I $D(PSNODE),$D(PSNOU),$D(^DIC(51.5)) W ?52,$S('$D(^DIC(51.5,PSNOU)):"",1:$P(^DIC(51.5,PSNOU,0),"^",1))
- I $D(ANS),ANS["?" K ANS W !,?24,"DISPENSE UNITS/ORDER UNITS: ",$S('$D(PSNODE):"",1:$P(PSNODE,"^",5)),!,?37,"DISPENSE UNIT: ",$S('$D(PSNODE):"",1:$P(PSNODE,"^",8)),!,?5 G FORM
- I $D(ANS),ANS']"" G TRY3^PSNCOMP
- I $D(ANS),'$D(^TMP($J,"PSNND",ANS)) W !!,"Invalid answer",! K ANS G FORM
- S (PSNFNM,KK)=$P(^TMP($J,"PSNND",ANS),"^",2)
- RESP R !,?10,"Is this a match < Reply Y, N or press return to continue > : ",ANS:DTIME S:'$T ANS="^" W ! I ANS']"" K ANS,PSNFORM G PUNT^PSNCOMP
- I ANS?.E1C.E G RESP
- I "Nn"[$E(ANS),'X K ANS,PSNFORM G PUNT^PSNCOMP
- I "Nn"[$E(ANS) K ANS,PSNFORM G FORM
- I ANS["^" S PSNFL=1 Q
- I ANS["?" D RES1^PSNHELP K ANS G RESP
- I "YyNn"'[$E(ANS) W !," Invalid Response " G RESP
- I $P(LIST(KK),"^",7)="I" W !,"Inactive VA Product entry has been selected!!",!! G FORM
- S PSNCLASS=$P(^PSNDF(50.68,PSNFNM,3),"^"),PSNNDF=PSNDA S PSNVAR="BLDIT^PSNCOMP" D ^PSNSTCK I $D(PSNFL) Q:PSNFL
- Q:'$D(ANS) I "NOno"[ANS K ANS Q
- SET S:'$D(^PSNTRAN(PSNB,0)) $P(^PSNTRAN(0),"^",4)=($P(^PSNTRAN(0),"^",4))+1,$P(^PSNTRAN(0),"^",3)=PSNB
- S ^PSNTRAN(PSNB,0)=PSNNDF_"^"_PSNFNM_"^"_PSNCLASS_"^^"_PSNSIZE_"^^"_PSNTYPE_"^"_DUZ D PKI W:$D(IOF) @IOF S:'$D(PSNFL) PSNFL=0 Q
- PRA ; PRINT DOSE FORM AND CLASS AFTER VA PRODUCT NAME IF A DUPLICATE
- ; S PSNDFM=$P(^PSNDF(PSNDA,2,$P(^PSNDF(PSNDA,5,KK,0),"^",2),0),"^",1),PSND=$P(^PS(50.606,PSNDFM,0),"^",1)
- ; S PSNVCL=$P(^PSNDF(PSNDA,2,$P(^PSNDF(PSNDA,5,KK,0),"^",2),0),"^",3),PSNVC=$P(^PS(50.605,PSNVCL,0),"^",1) W " ",PSND," ",PSNVC S PSNF=0 Q
- ; W " ",PSND," ",PSNVC S PSNF=0 Q
- Q
- OOPS W !!,"No match found" S ^PSNTRAN(PSNB,0)="0^^^^^^^"_DUZ Q
- Q
- Q
- STAR K ^TMP($J,"PSNND") S PSNRAN=0 S PSNM="" F WRT=0:0 S PSNM=$O(^TMP($J,"PSNDF1",PSNM)) Q:PSNM="" D SETARY1
- Q
- SETARY1 S CID=" " F KK=0:0 S KK=$O(^TMP($J,"PSNDF1",PSNM,KK)) Q:'KK S CID=$P($G(^PSNDF(50.68,KK,1)),"^",2) D ARRAY
- Q
- ARRAY S PSNRAN=PSNRAN+1 S ^TMP($J,"PSNND",PSNRAN)=PSNM_"^"_KK_"^"_$P(LIST(KK),"^",4)_"^"_$P(LIST(KK),"^",6)_"^"_CID_"^"_$P(LIST(KK),"^",7)_"^"_$S($P(LIST(KK),"^",8)="Tier ":"",1:$P(LIST(KK),"^",8))
- Q
- KILL K ANS,IFN,PSNDA,PSNDDA,PSNUNDA,PSNSTDA,DIC,II,MJL,JJ,NBR,PSNCLASS,PSNFL,PSNFNM,PSNFORM,PSNNAM,PSNNAME,DOS,NDP,PS,PT,STR,UNT,VV,VV1,PSNNDC,PSNNDF,PSNSP,PSNSIZE,PSNTYPE,PSNVAR,PSNSZ,PSNTRFL,PSNTYP,X,Y,PSNSZE
- K PSNTPE,PSNODE,PSNOU,VADC,PSNLOC,^TMP($J,"PSNND"),ASC,PSNRAN,PSNV,PSNWR,PSNX,PSNZ,WRT,BB,END,LIST,IEN,^TMP($J,"PSNDF1") Q
- STAR0 K ^TMP($J,"PSNDF1") F IEN=0:0 S IEN=$O(LIST(IEN)) Q:'IEN S ^TMP($J,"PSNDF1",$P(LIST(IEN),"^",2),IEN)=""
- Q
- ASKIT D PKSIZE^PSNOUT,PKTYPE^PSNOUT W !!,"Local drug ",$P(^PSDRUG(PSNB,0),"^"),!,"matches ",?11,PSNFORM,!,"PACKAGE SIZE: ",PSNSZE,!,"PACKAGE TYPE: ",PSNTPE
- W !?10,"Is this a match ?" K DIR S DIR("B")="YES",DIR(0)="Y" D ^DIR Q:$D(DIRUT)
- I Y(0)="NO" Q
- I Y(0)="YES" D SET^PSNHIT
- Q
- ASKIT1 S DUNCE=0 D PKSIZE^PSNOUT,PKTYPE^PSNOUT W !!,"Local drug ",$P(^PSDRUG(PSNB,0),"^"),!,"matches ",?11,PSNFORM,!,"PACKAGE SIZE: ",PSNSZE,!,"PACKAGE TYPE: ",PSNTPE
- W !?10,"Is this a match ?" K DIR S DIR("B")="YES",DIR(0)="Y" D ^DIR Q:$D(DIRUT)
- I Y(0)="NO" S DUNCE=1,NOMSYN=1
- I Y(0)="YES" D SET^PSNHIT
- Q
- EXTD S CMID=$P(^TMP($J,"PSNND",BB),"^",5)
- Q
- PKI N CS
- I +$P($G(^PSNDF(50.68,PSNFNM,7)),"^") S CS=$P(^(7),"^") D
- .S CS=$S(CS?1(1"2n",1"3n"):+CS_"C",+CS=2!(+CS=3)&(CS'["C"):+CS_"A",1:CS)
- .I $L(CS)=1,$P(^PSDRUG(PSNB,0),"^",3)[CS Q
- .I $P(^PSDRUG(PSNB,0),"^",3)[$E(CS),$P(^PSDRUG(PSNB,0),"^",3)[$E(CS,2) Q
- .W !!,"The CS Federal Schedule associated with this drug in the VA Product file"
- .W !,"represents a DEA, Special Handling code of "_CS,!!
- .W ?5,"Enter RETURN to continue..." R X:10
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSNHIT 5150 printed Feb 18, 2025@23:50:30 Page 2
- PSNHIT ;BIR/CCH&WRT-After match is made package size and type selected ; 02/08/00 8:41
- +1 ;;4.0;NATIONAL DRUG FILE;**22,47,65,492,396**; 30 Oct 98;Build 190
- +2 ;
- +3 ;Reference to ^DIC(51.5 supported by DBIA #1931
- +4 ;Reference to ^PSDRUG supported by DBIA #2352,#221
- +5 ;
- +6 SET ASC="Enter your choice or press return to continue: "
- HIT WRITE !!,"Match made with ",PSNLOC
- if $PIECE(^PSDRUG(PSNB,0),"^",9)=1
- WRITE ?62,"N/F"
- WRITE !," Now select VA Product Name ",!
- +1 SET PSNFL=0
- FORM KILL ANS,LIST,DA
- SET DA=PSNDA
- SET X=$$VAP^PSNAPIS(DA,.LIST)
- SET STOP=X
- DO STAR0
- DO STAR
- FOR PSNWR=0:0
- SET PSNWR=$ORDER(^TMP($JOB,"PSNND",PSNWR))
- if 'PSNWR
- QUIT
- WRTIT FOR BB=1:1:STOP
- DO EXTD
- Begin DoDot:1
- +1 WRITE !,BB," ",$PIECE(^TMP($JOB,"PSNND",BB),"^",1)_" "_$PIECE(^TMP($JOB,"PSNND",BB),"^",3)_" "_$PIECE(^TMP($JOB,"PSNND",BB),"^",4)_" "_CMID_" "_$SELECT($PIECE(^TMP($JOB,"PSNND",BB),"^",6)="I":"**INACTIVE**",1:"")
- +2 ;PPSN
- WRITE " "_$$GET1^DIQ(50.68,$PIECE(^TMP($JOB,"PSNND",BB),"^",2),109)
- +3 ; PSN*4*492 FMCT
- WRITE " "_$PIECE(^TMP($JOB,"PSNND",BB),"^",7)
- End DoDot:1
- IF BB#10=0
- IF STOP'=10
- WRITE !!,ASC
- READ ANS:DTIME
- if '$TEST
- SET ANS="^"
- if ANS="^"
- SET PSNFL=1
- if PSNFL
- QUIT
- if ANS]""
- QUIT
- +4 IF $DATA(ANS)
- IF ANS?.E1C.E
- GOTO FORM
- +5 IF $DATA(ANS)
- IF ANS["?"
- DO HIT1^PSNHELP
- KILL ANS
- GOTO FORM
- +6 if PSNFL
- QUIT
- IF $DATA(ANS)
- IF ANS']""
- KILL ANS
- +7 IF $DATA(ANS)
- IF ANS?.E1C.E
- GOTO FORM
- VAPN IF '$DATA(ANS)
- if $DATA(XRT0)
- SET XRTN=$TEXT(+0)
- if $DATA(XRT0)
- DO T1^%ZOSV
- READ !!,"Enter your choice: ",ANS:DTIME
- if '$TEST
- SET ANS="^"
- if ANS["^"
- SET PSNFL=1
- if PSNFL
- QUIT
- +1 IF ANS?.E1C.E
- KILL ANS
- GOTO VAPN
- +2 IF $DATA(ANS)
- IF ANS["?"
- DO NDC3^PSNHELP
- WRITE !!,"Match local drug ",PSNNAM," with "
- WRITE !,?40,"ORDER UNIT: "
- IF $DATA(PSNODE)
- IF $DATA(PSNOU)
- IF $DATA(^DIC(51.5))
- WRITE ?52,$SELECT('$DATA(^DIC(51.5,PSNOU)):"",1:$PIECE(^DIC(51.5,PSNOU,0),"^",1))
- +3 IF $DATA(ANS)
- IF ANS["?"
- KILL ANS
- WRITE !,?24,"DISPENSE UNITS/ORDER UNITS: ",$SELECT('$DATA(PSNODE):"",1:$PIECE(PSNODE,"^",5)),!,?37,"DISPENSE UNIT: ",$SELECT('$DATA(PSNODE):"",1:$PIECE(PSNODE,"^",8)),!,?5
- GOTO FORM
- +4 IF $DATA(ANS)
- IF ANS']""
- GOTO TRY3^PSNCOMP
- +5 IF $DATA(ANS)
- IF '$DATA(^TMP($JOB,"PSNND",ANS))
- WRITE !!,"Invalid answer",!
- KILL ANS
- GOTO FORM
- +6 SET (PSNFNM,KK)=$PIECE(^TMP($JOB,"PSNND",ANS),"^",2)
- RESP READ !,?10,"Is this a match < Reply Y, N or press return to continue > : ",ANS:DTIME
- if '$TEST
- SET ANS="^"
- WRITE !
- IF ANS']""
- KILL ANS,PSNFORM
- GOTO PUNT^PSNCOMP
- +1 IF ANS?.E1C.E
- GOTO RESP
- +2 IF "Nn"[$EXTRACT(ANS)
- IF 'X
- KILL ANS,PSNFORM
- GOTO PUNT^PSNCOMP
- +3 IF "Nn"[$EXTRACT(ANS)
- KILL ANS,PSNFORM
- GOTO FORM
- +4 IF ANS["^"
- SET PSNFL=1
- QUIT
- +5 IF ANS["?"
- DO RES1^PSNHELP
- KILL ANS
- GOTO RESP
- +6 IF "YyNn"'[$EXTRACT(ANS)
- WRITE !," Invalid Response "
- GOTO RESP
- +7 IF $PIECE(LIST(KK),"^",7)="I"
- WRITE !,"Inactive VA Product entry has been selected!!",!!
- GOTO FORM
- +8 SET PSNCLASS=$PIECE(^PSNDF(50.68,PSNFNM,3),"^")
- SET PSNNDF=PSNDA
- SET PSNVAR="BLDIT^PSNCOMP"
- DO ^PSNSTCK
- IF $DATA(PSNFL)
- if PSNFL
- QUIT
- +9 if '$DATA(ANS)
- QUIT
- IF "NOno"[ANS
- KILL ANS
- QUIT
- SET if '$DATA(^PSNTRAN(PSNB,0))
- SET $PIECE(^PSNTRAN(0),"^",4)=($PIECE(^PSNTRAN(0),"^",4))+1
- SET $PIECE(^PSNTRAN(0),"^",3)=PSNB
- +1 SET ^PSNTRAN(PSNB,0)=PSNNDF_"^"_PSNFNM_"^"_PSNCLASS_"^^"_PSNSIZE_"^^"_PSNTYPE_"^"_DUZ
- DO PKI
- if $DATA(IOF)
- WRITE @IOF
- if '$DATA(PSNFL)
- SET PSNFL=0
- QUIT
- PRA ; PRINT DOSE FORM AND CLASS AFTER VA PRODUCT NAME IF A DUPLICATE
- +1 ; S PSNDFM=$P(^PSNDF(PSNDA,2,$P(^PSNDF(PSNDA,5,KK,0),"^",2),0),"^",1),PSND=$P(^PS(50.606,PSNDFM,0),"^",1)
- +2 ; S PSNVCL=$P(^PSNDF(PSNDA,2,$P(^PSNDF(PSNDA,5,KK,0),"^",2),0),"^",3),PSNVC=$P(^PS(50.605,PSNVCL,0),"^",1) W " ",PSND," ",PSNVC S PSNF=0 Q
- +3 ; W " ",PSND," ",PSNVC S PSNF=0 Q
- +4 QUIT
- OOPS WRITE !!,"No match found"
- SET ^PSNTRAN(PSNB,0)="0^^^^^^^"_DUZ
- QUIT
- +1 QUIT
- +2 QUIT
- STAR KILL ^TMP($JOB,"PSNND")
- SET PSNRAN=0
- SET PSNM=""
- FOR WRT=0:0
- SET PSNM=$ORDER(^TMP($JOB,"PSNDF1",PSNM))
- if PSNM=""
- QUIT
- DO SETARY1
- +1 QUIT
- SETARY1 SET CID=" "
- FOR KK=0:0
- SET KK=$ORDER(^TMP($JOB,"PSNDF1",PSNM,KK))
- if 'KK
- QUIT
- SET CID=$PIECE($GET(^PSNDF(50.68,KK,1)),"^",2)
- DO ARRAY
- +1 QUIT
- ARRAY SET PSNRAN=PSNRAN+1
- SET ^TMP($JOB,"PSNND",PSNRAN)=PSNM_"^"_KK_"^"_$PIECE(LIST(KK),"^",4)_"^"_$PIECE(LIST(KK),"^",6)_"^"_CID_"^"_$PIECE(LIST(KK),"^",7)_"^"_$SELECT($PIECE(LIST(KK),"^",8)="Tier ":"",1:$PIECE(LIST(KK),"^",8))
- +1 QUIT
- KILL KILL ANS,IFN,PSNDA,PSNDDA,PSNUNDA,PSNSTDA,DIC,II,MJL,JJ,NBR,PSNCLASS,PSNFL,PSNFNM,PSNFORM,PSNNAM,PSNNAME,DOS,NDP,PS,PT,STR,UNT,VV,VV1,PSNNDC,PSNNDF,PSNSP,PSNSIZE,PSNTYPE,PSNVAR,PSNSZ,PSNTRFL,PSNTYP,X,Y,PSNSZE
- +1 KILL PSNTPE,PSNODE,PSNOU,VADC,PSNLOC,^TMP($JOB,"PSNND"),ASC,PSNRAN,PSNV,PSNWR,PSNX,PSNZ,WRT,BB,END,LIST,IEN,^TMP($JOB,"PSNDF1")
- QUIT
- STAR0 KILL ^TMP($JOB,"PSNDF1")
- FOR IEN=0:0
- SET IEN=$ORDER(LIST(IEN))
- if 'IEN
- QUIT
- SET ^TMP($JOB,"PSNDF1",$PIECE(LIST(IEN),"^",2),IEN)=""
- +1 QUIT
- ASKIT DO PKSIZE^PSNOUT
- DO PKTYPE^PSNOUT
- WRITE !!,"Local drug ",$PIECE(^PSDRUG(PSNB,0),"^"),!,"matches ",?11,PSNFORM,!,"PACKAGE SIZE: ",PSNSZE,!,"PACKAGE TYPE: ",PSNTPE
- +1 WRITE !?10,"Is this a match ?"
- KILL DIR
- SET DIR("B")="YES"
- SET DIR(0)="Y"
- DO ^DIR
- if $DATA(DIRUT)
- QUIT
- +2 IF Y(0)="NO"
- QUIT
- +3 IF Y(0)="YES"
- DO SET^PSNHIT
- +4 QUIT
- ASKIT1 SET DUNCE=0
- DO PKSIZE^PSNOUT
- DO PKTYPE^PSNOUT
- WRITE !!,"Local drug ",$PIECE(^PSDRUG(PSNB,0),"^"),!,"matches ",?11,PSNFORM,!,"PACKAGE SIZE: ",PSNSZE,!,"PACKAGE TYPE: ",PSNTPE
- +1 WRITE !?10,"Is this a match ?"
- KILL DIR
- SET DIR("B")="YES"
- SET DIR(0)="Y"
- DO ^DIR
- if $DATA(DIRUT)
- QUIT
- +2 IF Y(0)="NO"
- SET DUNCE=1
- SET NOMSYN=1
- +3 IF Y(0)="YES"
- DO SET^PSNHIT
- +4 QUIT
- EXTD SET CMID=$PIECE(^TMP($JOB,"PSNND",BB),"^",5)
- +1 QUIT
- PKI NEW CS
- +1 IF +$PIECE($GET(^PSNDF(50.68,PSNFNM,7)),"^")
- SET CS=$PIECE(^(7),"^")
- Begin DoDot:1
- +2 SET CS=$SELECT(CS?1(1"2n",1"3n"):+CS_"C",+CS=2!(+CS=3)&(CS'["C"):+CS_"A",1:CS)
- +3 IF $LENGTH(CS)=1
- IF $PIECE(^PSDRUG(PSNB,0),"^",3)[CS
- QUIT
- +4 IF $PIECE(^PSDRUG(PSNB,0),"^",3)[$EXTRACT(CS)
- IF $PIECE(^PSDRUG(PSNB,0),"^",3)[$EXTRACT(CS,2)
- QUIT
- +5 WRITE !!,"The CS Federal Schedule associated with this drug in the VA Product file"
- +6 WRITE !,"represents a DEA, Special Handling code of "_CS,!!
- +7 WRITE ?5,"Enter RETURN to continue..."
- READ X:10
- End DoDot:1
- +8 QUIT