- PSOPTPST ;BIR/DSD - Post Patient Selection Action ;07/25/96
- ;;7.0;OUTPATIENT PHARMACY;**7,71,88,146,157,143,225**;DEC 1997;Build 0
- ;External reference to SDCO22 supported by DBIA 1579
- ;External reference to IBE(350.1,"ANEW" supported by DBIA 592
- ;External reference to PS(55 supported by DBIA 2228
- ;External reference to IBARX supported by DBIA 125
- ;External reference to $$GETSHAD^DGUTL3 supported by DBIA 4462
- START S PSOQFLG=0
- D GET ; Gets data from Patient file
- D DEAD G:PSOQFLG END ; Checks to see if patient still alive
- G:$G(PSOFROM("PTLKUP"))']"" END ; skips questions if not called by RX data entry
- D INP G:PSOQFLG END ;Checks to see if inpatient and whether to continue
- D CNH G:PSOQFLG END ; Checks to see if nursing home patient
- D ELIG ; Checks eligibility
- D:$G(DUZ("AG"))="V" COPAY ; Deals with copay
- D ADDRESS ; Display address information
- D:$G(^PS(55,PSODFN,1))]"" REMARKS ; Displays narrative about patient
- END D EOJ
- Q
- ;----------------------------------------------------------
- GET K DIC,DR,DIQ S DIC=2,DA=PSODFN,DR=".1;.172;.351;.361;148",DIQ="PSOPTPST"
- D EN^DIQ1 K DIC,DA,DR,DIQ
- Q
- ;
- DEAD ;
- I $G(PSOPTPST(2,PSODFN,.351))]"" S (PSODEATH,PSOQFLG)=1 S SSN=$P(^DPT(PSODFN,0),"^",9) W !?10,$C(7),PSORX("NAME")_" ("_$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)_") DIED "_PSOPTPST(2,PSODFN,.351),! S:$G(POERR) POERR("DEAD")=1 D
- .;I '$O(^PS(55,PSODFN,"P","A",DT)) Q
- .S ACOM="Date of Death "_PSOPTPST(2,PSODFN,.351)_".",ZTRTN="CAN^PSOCAN3",ZTDESC="Outpatient Pharmacy Autocancel Due to Death of Patient",ZTSAVE("ACOM")="",ZTSAVE("PSODFN")="",ZTSAVE("PSODEATH")=""
- .S ZTIO="",PSOCLC=DUZ,ZTSAVE("PSOCLC")="",ZTDTH=$H D ^%ZTLOAD K ACOM,ZTSK,PSODEATH
- Q
- ;
- INP I '$G(PSOXFLG),'$G(PSOFIN),$G(PSOPTPST(2,PSODFN,.1))]"" S PSOXFLG=1,SSN=$P(^DPT(PSODFN,0),"^",9) W !!?10,$C(7),PSORX("NAME")_" ("_$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)_")" K SSN
- I $G(PSOPTPST(2,PSODFN,.1))]"" W !?10,$C(7),"Patient is an Inpatient on Ward "_PSOPTPST(2,PSODFN,.1)_" !!" D DIR
- Q
- TPB ;
- N PSOTPSSN
- I '$G(PSODFN) Q
- I $D(^PS(52.91,PSODFN,0)) I '$P(^PS(52.91,PSODFN,0),"^",3)!($P(^(0),"^",3)>DT) D
- .S PSOTPSSN=$P($G(^DPT(PSODFN,0)),"^",9)
- .I $G(PSOFIN)!($G(MEDP)) D
- ..I $G(MEDP) W !!?10,$C(7),$P($G(^DPT(PSODFN,0)),"^")_" ("_$E(PSOTPSSN,1,3)_"-"_$E(PSOTPSSN,4,5)_"-"_$E(PSOTPSSN,6,9)_")" Q
- ..I $G(PSOFIN) I $G(PSOPTPST(2,PSODFN,148))="YES"!($G(PSOPTPST(2,PSODFN,.1))]"") W !!?10,$C(7),$P($G(^DPT(PSODFN,0)),"^")_" ("_$E(PSOTPSSN,1,3)_"-"_$E(PSOTPSSN,4,5)_"-"_$E(PSOTPSSN,6,9)_")"
- .I '$G(PSOFIN),'$G(MEDP) W !
- .W !?10,"Patient is eligible for the Transitional Pharmacy Benefit!!" D DIR
- Q
- ;
- CNH I $G(MEDP),$G(PSOPTPST(2,PSODFN,148))="YES",$G(PSOPTPST(2,PSODFN,.1))']"" D
- .S SSN=$P(^DPT(PSODFN,0),"^",9) W !!?10,$C(7),PSORX("NAME")_" ("_$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)_")" K SSN
- K PSORX("CNH") I $G(PSOPTPST(2,PSODFN,148))="YES" W !?10,$C(7),"Patient is in a Contract Nursing Home !!" D DIR S:'$G(PSOQFLG) PSORX("CNH")=1
- Q
- ;
- ELIG I $G(PSOPTPST(2,PSODFN,.361))]"",$G(PSOPTPST(2,PSODFN,.172))'="I" W !,"MAS Eligibility: "_PSOPTPST(2,PSODFN,.361)
- S DFN=PSODFN D RE^PSODEM
- Q
- ;
- COPAY K PSOBILL,PSOCPAY S DFN=PSODFN,(X,PSOPTIB)=$P($G(^PS(59,+PSOSITE,"IB")),"^")_"^"_PSODFN D XTYPE^IBARX
- I '$D(^IBE(350.1,"ANEW",+PSOPTIB,1,1)) S PSOQFLG=1 D K PSOPTIB Q
- .W $C(7),!!,"There is a problem with the IB SERVICE/SECTION entry in your Pharmacy Site File."
- .W !,"You will not be able to enter any new prescriptions until this is corrected!",!
- S (ACTYP,BL)="",(PSOBILL,PSOCPAY)=0 I +Y=-1 W !,"ERROR IN COPAY ELIGIBILITY ENCOUNTERED." G COPAYX
- COPAY1 S ACTYP=$O(Y(ACTYP)) G:'ACTYP COPAYX F III=0:0 S BL=$O(Y(ACTYP,BL)) Q:BL="" I BL>0 S PSOBILL=BL,PSOCPAY=BL_"^"_Y(ACTYP,BL)
- G COPAY1
- COPAYX K X,Y,ACTYP,BL,III,PSOPTIB
- ;I $G(PSOBILL)
- D QST
- Q
- ;
- ADDRESS N DFN S (DA,DFN)=PSODFN D ADD^VADPT K DFN,PSOI,DA,DR
- Q
- ;
- F PSOI=1:1 Q:$P(PSOX," ",PSOI,900)="" W:$X+$L($P(PSOX," ",PSOI))+$L(" ")>IOM !?5 W $P(PSOX," ",PSOI)_" "
- K PSOX,PSOI
- Q
- ;
- DIR K DIR W !
- S DIR(0)="Y",DIR("B")="NO",DIR("A")="Do You Want To Continue" D ^DIR K DIR
- S:'Y PSOQFLG=1 K X,Y,DIRUT,DTOUT,DUOUT
- Q
- ;
- EOJ K:PSOQFLG PSORX("CNH") K PSOPTPST,VAPA
- Q
- QST ;Ask new questions for Copay
- I '$$DT^PSOMLLDT Q
- K PSOIBQS
- I $G(PSOBILL) S PSOIBQS(PSODFN,"SC")=""
- S PSOIBQS(PSODFN,"SC>50")=""
- I +$P($$CVEDT^DGCV(PSODFN),"^",3) S PSOIBQS(PSODFN,"CV")=""
- I $$AO^SDCO22(PSODFN) S PSOIBQS(PSODFN,"VEH")=""
- I $$IR^SDCO22(PSODFN) S PSOIBQS(PSODFN,"RAD")=""
- I $$EC^SDCO22(PSODFN) S PSOIBQS(PSODFN,"PGW")=""
- I $L($T(GETSHAD^DGUTL3)) S:$$GETSHAD^DGUTL3(PSODFN)=1 PSOIBQS(PSODFN,"SHAD")=""
- I $P($$GETSTAT^DGMSTAPI(PSODFN),"^",2)="Y" S PSOIBQS(PSODFN,"MST")=""
- I $T(GETCUR^DGNTAPI)]"" N PSONCP,PSONCPX S PSONCPX=$$GETCUR^DGNTAPI(PSODFN,"PSONCP") I $P($G(PSONCP("IND")),"^")="Y" S PSOIBQS(PSODFN,"HNC")=""
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOPTPST 4927 printed Feb 18, 2025@23:59:36 Page 2
- PSOPTPST ;BIR/DSD - Post Patient Selection Action ;07/25/96
- +1 ;;7.0;OUTPATIENT PHARMACY;**7,71,88,146,157,143,225**;DEC 1997;Build 0
- +2 ;External reference to SDCO22 supported by DBIA 1579
- +3 ;External reference to IBE(350.1,"ANEW" supported by DBIA 592
- +4 ;External reference to PS(55 supported by DBIA 2228
- +5 ;External reference to IBARX supported by DBIA 125
- +6 ;External reference to $$GETSHAD^DGUTL3 supported by DBIA 4462
- START SET PSOQFLG=0
- +1 ; Gets data from Patient file
- DO GET
- +2 ; Checks to see if patient still alive
- DO DEAD
- if PSOQFLG
- GOTO END
- +3 ; skips questions if not called by RX data entry
- if $GET(PSOFROM("PTLKUP"))']""
- GOTO END
- +4 ;Checks to see if inpatient and whether to continue
- DO INP
- if PSOQFLG
- GOTO END
- +5 ; Checks to see if nursing home patient
- DO CNH
- if PSOQFLG
- GOTO END
- +6 ; Checks eligibility
- DO ELIG
- +7 ; Deals with copay
- if $GET(DUZ("AG"))="V"
- DO COPAY
- +8 ; Display address information
- DO ADDRESS
- +9 ; Displays narrative about patient
- if $GET(^PS(55,PSODFN,1))]""
- DO REMARKS
- END DO EOJ
- +1 QUIT
- +2 ;----------------------------------------------------------
- GET KILL DIC,DR,DIQ
- SET DIC=2
- SET DA=PSODFN
- SET DR=".1;.172;.351;.361;148"
- SET DIQ="PSOPTPST"
- +1 DO EN^DIQ1
- KILL DIC,DA,DR,DIQ
- +2 QUIT
- +3 ;
- DEAD ;
- +1 IF $GET(PSOPTPST(2,PSODFN,.351))]""
- SET (PSODEATH,PSOQFLG)=1
- SET SSN=$PIECE(^DPT(PSODFN,0),"^",9)
- WRITE !?10,$CHAR(7),PSORX("NAME")_" ("_$EXTRACT(SSN,1,3)_"-"_$EXTRACT(SSN,4,5)_"-"_$EXTRACT(SSN,6,9)_") DIED "_PSOPTPST(2,PSODFN,.351),!
- if $GET(POERR)
- SET POERR("DEAD")=1
- Begin DoDot:1
- +2 ;I '$O(^PS(55,PSODFN,"P","A",DT)) Q
- +3 SET ACOM="Date of Death "_PSOPTPST(2,PSODFN,.351)_"."
- SET ZTRTN="CAN^PSOCAN3"
- SET ZTDESC="Outpatient Pharmacy Autocancel Due to Death of Patient"
- SET ZTSAVE("ACOM")=""
- SET ZTSAVE("PSODFN")=""
- SET ZTSAVE("PSODEATH")=""
- +4 SET ZTIO=""
- SET PSOCLC=DUZ
- SET ZTSAVE("PSOCLC")=""
- SET ZTDTH=$HOROLOG
- DO ^%ZTLOAD
- KILL ACOM,ZTSK,PSODEATH
- End DoDot:1
- +5 QUIT
- +6 ;
- INP IF '$GET(PSOXFLG)
- IF '$GET(PSOFIN)
- IF $GET(PSOPTPST(2,PSODFN,.1))]""
- SET PSOXFLG=1
- SET SSN=$PIECE(^DPT(PSODFN,0),"^",9)
- WRITE !!?10,$CHAR(7),PSORX("NAME")_" ("_$EXTRACT(SSN,1,3)_"-"_$EXTRACT(SSN,4,5)_"-"_$EXTRACT(SSN,6,9)_")"
- KILL SSN
- +1 IF $GET(PSOPTPST(2,PSODFN,.1))]""
- WRITE !?10,$CHAR(7),"Patient is an Inpatient on Ward "_PSOPTPST(2,PSODFN,.1)_" !!"
- DO DIR
- +2 QUIT
- TPB ;
- +1 NEW PSOTPSSN
- +2 IF '$GET(PSODFN)
- QUIT
- +3 IF $DATA(^PS(52.91,PSODFN,0))
- IF '$PIECE(^PS(52.91,PSODFN,0),"^",3)!($PIECE(^(0),"^",3)>DT)
- Begin DoDot:1
- +4 SET PSOTPSSN=$PIECE($GET(^DPT(PSODFN,0)),"^",9)
- +5 IF $GET(PSOFIN)!($GET(MEDP))
- Begin DoDot:2
- +6 IF $GET(MEDP)
- WRITE !!?10,$CHAR(7),$PIECE($GET(^DPT(PSODFN,0)),"^")_" ("_$EXTRACT(PSOTPSSN,1,3)_"-"_$EXTRACT(PSOTPSSN,4,5)_"-"_$EXTRACT(PSOTPSSN,6,9)_")"
- QUIT
- +7 IF $GET(PSOFIN)
- IF $GET(PSOPTPST(2,PSODFN,148))="YES"!($GET(PSOPTPST(2,PSODFN,.1))]"")
- WRITE !!?10,$CHAR(7),$PIECE($GET(^DPT(PSODFN,0)),"^")_" ("_$EXTRACT(PSOTPSSN,1,3)_"-"_$EXTRACT(PSOTPSSN,4,5)_"-"_$EXTRACT(PSOTPSSN,6,9)_")"
- End DoDot:2
- +8 IF '$GET(PSOFIN)
- IF '$GET(MEDP)
- WRITE !
- +9 WRITE !?10,"Patient is eligible for the Transitional Pharmacy Benefit!!"
- DO DIR
- End DoDot:1
- +10 QUIT
- +11 ;
- CNH IF $GET(MEDP)
- IF $GET(PSOPTPST(2,PSODFN,148))="YES"
- IF $GET(PSOPTPST(2,PSODFN,.1))']""
- Begin DoDot:1
- +1 SET SSN=$PIECE(^DPT(PSODFN,0),"^",9)
- WRITE !!?10,$CHAR(7),PSORX("NAME")_" ("_$EXTRACT(SSN,1,3)_"-"_$EXTRACT(SSN,4,5)_"-"_$EXTRACT(SSN,6,9)_")"
- KILL SSN
- End DoDot:1
- +2 KILL PSORX("CNH")
- IF $GET(PSOPTPST(2,PSODFN,148))="YES"
- WRITE !?10,$CHAR(7),"Patient is in a Contract Nursing Home !!"
- DO DIR
- if '$GET(PSOQFLG)
- SET PSORX("CNH")=1
- +3 QUIT
- +4 ;
- ELIG IF $GET(PSOPTPST(2,PSODFN,.361))]""
- IF $GET(PSOPTPST(2,PSODFN,.172))'="I"
- WRITE !,"MAS Eligibility: "_PSOPTPST(2,PSODFN,.361)
- +1 SET DFN=PSODFN
- DO RE^PSODEM
- +2 QUIT
- +3 ;
- COPAY KILL PSOBILL,PSOCPAY
- SET DFN=PSODFN
- SET (X,PSOPTIB)=$PIECE($GET(^PS(59,+PSOSITE,"IB")),"^")_"^"_PSODFN
- DO XTYPE^IBARX
- +1 IF '$DATA(^IBE(350.1,"ANEW",+PSOPTIB,1,1))
- SET PSOQFLG=1
- Begin DoDot:1
- +2 WRITE $CHAR(7),!!,"There is a problem with the IB SERVICE/SECTION entry in your Pharmacy Site File."
- +3 WRITE !,"You will not be able to enter any new prescriptions until this is corrected!",!
- End DoDot:1
- KILL PSOPTIB
- QUIT
- +4 SET (ACTYP,BL)=""
- SET (PSOBILL,PSOCPAY)=0
- IF +Y=-1
- WRITE !,"ERROR IN COPAY ELIGIBILITY ENCOUNTERED."
- GOTO COPAYX
- COPAY1 SET ACTYP=$ORDER(Y(ACTYP))
- if 'ACTYP
- GOTO COPAYX
- FOR III=0:0
- SET BL=$ORDER(Y(ACTYP,BL))
- if BL=""
- QUIT
- IF BL>0
- SET PSOBILL=BL
- SET PSOCPAY=BL_"^"_Y(ACTYP,BL)
- +1 GOTO COPAY1
- COPAYX KILL X,Y,ACTYP,BL,III,PSOPTIB
- +1 ;I $G(PSOBILL)
- +2 DO QST
- +3 QUIT
- +4 ;
- ADDRESS NEW DFN
- SET (DA,DFN)=PSODFN
- DO ADD^VADPT
- KILL DFN,PSOI,DA,DR
- +1 QUIT
- +2 ;
- WRITE !!,?5
- +1 FOR PSOI=1:1
- if $PIECE(PSOX," ",PSOI,900)=""
- QUIT
- if $X+$LENGTH($PIECE(PSOX," ",PSOI))+$LENGTH(" ")>IOM
- WRITE !?5
- WRITE $PIECE(PSOX," ",PSOI)_" "
- +2 KILL PSOX,PSOI
- +3 QUIT
- +4 ;
- DIR KILL DIR
- WRITE !
- +1 SET DIR(0)="Y"
- SET DIR("B")="NO"
- SET DIR("A")="Do You Want To Continue"
- DO ^DIR
- KILL DIR
- +2 if 'Y
- SET PSOQFLG=1
- KILL X,Y,DIRUT,DTOUT,DUOUT
- +3 QUIT
- +4 ;
- EOJ if PSOQFLG
- KILL PSORX("CNH")
- KILL PSOPTPST,VAPA
- +1 QUIT
- QST ;Ask new questions for Copay
- +1 IF '$$DT^PSOMLLDT
- QUIT
- +2 KILL PSOIBQS
- +3 IF $GET(PSOBILL)
- SET PSOIBQS(PSODFN,"SC")=""
- +4 SET PSOIBQS(PSODFN,"SC>50")=""
- +5 IF +$PIECE($$CVEDT^DGCV(PSODFN),"^",3)
- SET PSOIBQS(PSODFN,"CV")=""
- +6 IF $$AO^SDCO22(PSODFN)
- SET PSOIBQS(PSODFN,"VEH")=""
- +7 IF $$IR^SDCO22(PSODFN)
- SET PSOIBQS(PSODFN,"RAD")=""
- +8 IF $$EC^SDCO22(PSODFN)
- SET PSOIBQS(PSODFN,"PGW")=""
- +9 IF $LENGTH($TEXT(GETSHAD^DGUTL3))
- if $$GETSHAD^DGUTL3(PSODFN)=1
- SET PSOIBQS(PSODFN,"SHAD")=""
- +10 IF $PIECE($$GETSTAT^DGMSTAPI(PSODFN),"^",2)="Y"
- SET PSOIBQS(PSODFN,"MST")=""
- +11 IF $TEXT(GETCUR^DGNTAPI)]""
- NEW PSONCP,PSONCPX
- SET PSONCPX=$$GETCUR^DGNTAPI(PSODFN,"PSONCP")
- IF $PIECE($GET(PSONCP("IND")),"^")="Y"
- SET PSOIBQS(PSODFN,"HNC")=""
- +12 QUIT