- PSOTPCAN ;BIR/RTR - TPB Utility routine ;08/23/03
- ;;7.0;OUTPATIENT PHARMACY;**146,153,163,227**;DEC 1997
- ;External reference to PS(55 supported by DBIA 2228
- ;External reference to VA(200 supported by DBIA 224
- ;
- ;Check Rx being DC'd, if it's a TPB Rx, check to inactivate patient
- ;Called from all DC actions
- CAN(PSOTPRCX) ;
- Q ; placed out of order by PSO*7*227
- I '$G(PSOTPRCX) Q
- N PSOTPRC
- S PSOTPRC=$P($G(^PSRX(PSOTPRCX,0)),"^",2)
- I '$G(PSOTPRC) Q
- I '$P($G(^PSRX(PSOTPRCX,"TPB")),"^") Q
- I '$D(^PS(52.91,PSOTPRC,0)) Q
- I $P($G(^PS(52.91,PSOTPRC,0)),"^",3),$P($G(^(0)),"^",3)'>DT Q
- ;Patient is active in the TPB File, and TPB Rx is being canceled
- I PSOTPRC'=$P($G(^PSRX(PSOTPRCX,0)),"^",2) Q
- N PSOTPCSS,PSOTCXFL,PSOTC1,PSOTC2,PSOTC3,X1,X2,DA,DR,DIE,X,Y
- S PSOTCXFL=0
- S X1=DT,X2=-1 D C^%DTC S PSOTC3=X
- F PSOTC1=PSOTC3:0 S PSOTC1=$O(^PS(55,PSOTPRC,"P","A",PSOTC1)) Q:'PSOTC1!(PSOTCXFL) S PSOTC2="" F S PSOTC2=$O(^PS(55,PSOTPRC,"P","A",PSOTC1,PSOTC2)) Q:PSOTC2=""!(PSOTCXFL) D
- .I $P($G(^PSRX(PSOTC2,0)),"^",2)'=PSOTPRC Q
- .S PSOTPCSS=$P($G(^PSRX(PSOTC2,"STA")),"^")
- .I PSOTPCSS'=0,PSOTPCSS'=1,PSOTPCSS'=2,PSOTPCSS'=3,PSOTPCSS'=4,PSOTPCSS'=5,PSOTPCSS'=16 Q
- .I $P($G(^PSRX(PSOTC2,"TPB")),"^"),$P($G(^(2)),"^",6)'<DT S PSOTCXFL=1
- I 'PSOTCXFL K DA,DIE,DR S DA=PSOTPRC,DIE="^PS(52.91,",DR="2////"_DT_";3////"_6 D ^DIE K DIE,DA,DR
- Q
- ;
- MARK ;Mark Rx as TPB Rx if applicable
- N PSOTPODE,PSOZTRX
- I '$G(PSOX("IRXN")) Q
- I '$D(^PSRX(PSOX("IRXN"),0)) Q
- I '$G(PSOTPBFG) Q
- ;I $G(PSOFDR) Q
- S PSOTPODE=$G(^PSRX(PSOX("IRXN"),0))
- I '$P(PSOTPODE,"^",2)!('$P(PSOTPODE,"^",3))!('$P(PSOTPODE,"^",4)) Q
- S PSOZTRX=$P($G(^PS(53,+$P(PSOTPODE,"^",3),0)),"^") I $$UP^XLFSTR(PSOZTRX)'="NON-VA" Q
- I '$P($G(^VA(200,+$P(PSOTPODE,"^",4),"TPB")),"^") Q
- I $P($G(^VA(200,+$P(PSOTPODE,"^",4),"TPB")),"^",5)'=0 Q
- I '$D(^PS(52.91,+$P(PSOTPODE,"^",2),0)) Q
- I $P($G(^PS(52.91,+$P(PSOTPODE,"^",2),0)),"^",3),$P($G(^(0)),"^",3)'>DT Q
- ;Hard setting, to avoid DIE kiling any needed variables, no cross references on field, if added, need to use FileMan here
- S $P(^PSRX(PSOX("IRXN"),"TPB"),"^")=1
- Q
- MARKV ;Mark from Verify action
- N PSOTPV1,PSOTPV2
- I '$G(PSONVLP) Q
- I '$D(^PSRX(PSONVLP,0)) Q
- I '$G(PSOTPBFG) Q
- ;I $G(PSOFDR) Q
- S PSOTPV1=$G(^PSRX(PSONVLP,0))
- I '$P(PSOTPV1,"^",2)!('$P(PSOTPV1,"^",3))!('$P(PSOTPV1,"^",4)) Q
- S PSOTPV2=$P($G(^PS(53,+$P(PSOTPV1,"^",3),0)),"^") I $$UP^XLFSTR(PSOTPV2)'="NON-VA" Q
- I '$P($G(^VA(200,+$P(PSOTPV1,"^",4),"TPB")),"^") Q
- I $P($G(^VA(200,+$P(PSOTPV1,"^",4),"TPB")),"^",5)'=0 Q
- I '$D(^PS(52.91,+$P(PSOTPV1,"^",2),0)) Q
- I $P($G(^PS(52.91,+$P(PSOTPV1,"^",2),0)),"^",3),$P($G(^(0)),"^",3)'>DT Q
- S $P(^PSRX(PSONVLP,"TPB"),"^")=1
- Q
- RXPAT ;Sets Rx patient status to null
- N PSOZZTRX
- I $G(X),$G(X)'>DT D
- .S PSOZZTRX=$P($G(^PS(53,+$P($G(^PS(55,DA,"PS")),"^"),0)),"^") S PSOZZTRX=$$UP^XLFSTR(PSOZZTRX) I PSOZZTRX="NON-VA" S $P(^PS(55,DA,"PS"),"^")=""
- Q
- SET(PSOTPPST) ;Pass in DFN on a hard set of INACTIVATION OF BENEFIT DATE
- N PSOZXTRX
- I $P($G(^PS(52.91,PSOTPPST,0)),"^",3),$P($G(^(0)),"^",3)'>DT S PSOZXTRX=$P($G(^PS(53,+$P($G(^PS(55,PSOTPPST,"PS")),"^"),0)),"^") I $$UP^XLFSTR(PSOZXTRX)="NON-VA" S $P(^PS(55,PSOTPPST,"PS"),"^")=""
- Q
- PCAP(PSOPAPPT) ;Find nearest Primary Care appointment
- Q "TODAY AT NOON"
- ;
- PDIR(PSOTPEX) ;
- Q:'$G(PSOTPEX)
- N PSOTPEXS
- S PSOTPEXT=0
- S PSOTPEXS=$P($G(^DPT(PSOTPEX,0)),"^",9)
- W !!?10,$C(7),$P($G(^DPT(PSOTPEX,0)),"^")_" ("_$E(PSOTPEXS,1,3)_"-"_$E(PSOTPEXS,4,5)_"-"_$E(PSOTPEXS,6,9)_")"
- W !?10,"Patient is eligible for the Transitional Pharmacy Benefit!!"
- W ! K DIR S DIR(0)="E",DIR("A")="Press <ret> to continue, '^' to exit" D ^DIR K DIR I Y'=1 S PSOTPEXT=1
- Q
- VOPN ;
- I '$G(PSOTPPEN) Q
- I '$D(^PSRX(PSOTPPEN,0)) Q
- N PSOTPPE3,PSOTPPE4,PSOTPPE5,PSOTPPE6,PSOTPPE7,PSOTPPE8
- S PSOTPPE6=1
- S PSOTPPE3=$P($G(^PSRX(PSOTPPEN,0)),"^",3),PSOTPPE4=$P($G(^PSRX(PSOTPPEN,0)),"^",4)
- VOPNX ;
- I 'PSOTPPE4 S PSOTPPEX=1,PSOTPPE5(PSOTPPE6)="Unknown Provider!",PSOTPPE6=PSOTPPE6+1
- I 'PSOTPPE3 S PSOTPPEX=1 S PSOTPPE5(PSOTPPE6)="Unknown Patient Status!",PSOTPPE6=PSOTPPE6+1
- I PSOTPPE4,'$P($G(^VA(200,PSOTPPE4,"TPB")),"^") S PSOTPPE5(PSOTPPE6)="Provider is not flagged as a NON-VA PRESCRIBER!",PSOTPPE6=PSOTPPE6+1,PSOTPPEX=1
- I PSOTPPE4,$P($G(^VA(200,PSOTPPE4,"TPB")),"^",5)'=0 S PSOTPPE5(PSOTPPE6)="Provider is not flagged as not being on exclusionary list!",PSOTPPE6=PSOTPPE6+1,PSOTPPEX=1
- I PSOTPPE3 S PSOTPPE7=$P($G(^PS(53,PSOTPPE3,0)),"^") S PSOTPPE7=$$UP^XLFSTR(PSOTPPE7) I PSOTPPE7'="NON-VA" S PSOTPPE5(PSOTPPE6)="Rx Patient Status is not equal to 'NON-VA'!",PSOTPPE6=PSOTPPE6+1,PSOTPPEX=1
- I $G(PSOTPPEX) D I $G(PSOTPPE9) S VALMSG="Cannot Verify through this option"
- .W ! F PSOTPPE8=0:0 S PSOTPPE8=$O(PSOTPPE5(PSOTPPE8)) Q:'PSOTPPE8 W !,$G(PSOTPPE5(PSOTPPE8))
- .K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
- Q
- VOPNR ;
- I '$G(PSOTPPEN) Q
- I '$D(^PS(52.41,PSOTPPEN,0)) Q
- N PSOTPPE3,PSOTPPE4,PSOTPPE5,PSOTPPE6,PSOTPPE7,PSOTPPE8
- S PSOTPPE6=1
- I $P(^PS(52.41,PSOTPPEN,0),"^",3)="RNW",$D(^PSRX(+$P(^PS(52.41,PSOTPPEN,0),"^",21),0)) S PSOTPPE3=$P($G(^PSRX(+$P(^PS(52.41,PSOTPPEN,0),"^",21),0)),"^",3) G NOREN
- S PSOTPPE3=$P($G(^PS(55,+$P($G(^PS(52.41,PSOTPPEN,0)),"^",2),"PS")),"^")
- NOREN ;
- S PSOTPPE4=$P($G(^PS(52.41,PSOTPPEN,0)),"^",5)
- G VOPNX
- ;
- DSPL(PSOTPWRN) ;
- N DIR,PSOTPWR1,PSOTPWR2,PSOTPWR3
- I '$G(PSOTPWRN) Q
- I '$D(^PS(52.41,PSOTPWRN,0)) Q
- I $P(^PS(52.41,PSOTPWRN,0),"^",3)="RNW",$D(^PSRX(+$P(^PS(52.41,PSOTPWRN,0),"^",21),0)) D Q
- . S PSOTPWR1=$P($G(^PSRX(+$P(^PS(52.41,PSOTPWRN,0),"^",21),0)),"^",3)
- . S PSOTPWR2=$P($G(^PS(53,+PSOTPWR1,0)),"^"),PSOTPWR3=$$UP^XLFSTR(PSOTPWR2)
- . I PSOTPWR3="NON-VA" D
- . . K DIR W !!,"This order has an Rx Patient Status of 'NON-VA'!",! K DIR S DIR(0)="E",DIR("A")="Press return to continue" D ^DIR K DIR
- . . Q
- . Q
- S PSOTPWR1=$P($G(^PS(55,+$P($G(^PS(52.41,PSOTPWRN,0)),"^",2),"PS")),"^")
- S PSOTPWR2=$P($G(^PS(53,+PSOTPWR1,0)),"^") S PSOTPWR3=$$UP^XLFSTR(PSOTPWR2)
- I PSOTPWR3="NON-VA" D
- .W !!,"This order has an Rx Patient Status of 'NON-VA'!",! K DIR S DIR(0)="E",DIR("A")="Press return to continue" D ^DIR K DIR
- Q
- EXFLAG(PSOTPPX) ;Exit TPB RX option, reset TPG flag if necessary,
- ;and possibly delete inactive date and reason code for patient in 52.91
- I '$G(DT) S DT=$$DT^XLFDT
- I '$G(PSOTPPX) Q
- I '$D(^PS(52.91,PSOTPPX,0)) Q
- I $E($P(^PS(52.91,PSOTPPX,0),"^",3),1,7)'=DT Q
- I $P(^PS(52.91,PSOTPPX,0),"^",4)'=6 Q
- N DR,DIE,X1,X2,X,Y,DA,PSOTPPX1,PSOTPPX2,PSOTPPX3,PSOTPPX4,PSOTPPX5,PSOTPPX6,PSOTPPX7,PSOTPPX9
- S X1=DT,X2=-1 D C^%DTC S PSOTPPX1=X
- S PSOTPPX9=0
- F PSOTPPX2=PSOTPPX1:0 S PSOTPPX2=$O(^PS(55,PSOTPPX,"P","A",PSOTPPX2)) Q:'PSOTPPX2 S PSOTPPX3="" F S PSOTPPX3=$O(^PS(55,PSOTPPX,"P","A",PSOTPPX2,PSOTPPX3)) Q:PSOTPPX3="" D
- .I PSOTPPX'=$P($G(^PSRX(PSOTPPX3,0)),"^",2) Q
- .I $P($G(^PSRX(PSOTPPX3,"TPB")),"^") Q
- .I $E($P($G(^PSRX(PSOTPPX3,2)),"^"),1,7)'=DT Q
- .S PSOTPPX4=$P($G(^PSRX(PSOTPPX3,"STA")),"^") I PSOTPPX4="" Q
- .I PSOTPPX4'=0,PSOTPPX4'=1,PSOTPPX4'=2,PSOTPPX4'=3,PSOTPPX4'=4,PSOTPPX4'=5,PSOTPPX4'=16 Q
- .S PSOTPPX5=$P(^PSRX(PSOTPPX3,0),"^",3),PSOTPPX6=$P(^(0),"^",4)
- .I 'PSOTPPX5!('PSOTPPX6) Q
- .S PSOTPPX7=$P($G(^PS(53,+PSOTPPX5,0)),"^") S PSOTPPX7=$$UP^XLFSTR(PSOTPPX7) I PSOTPPX7'="NON-VA" Q
- .I '$P($G(^VA(200,PSOTPPX6,"TPB")),"^")!($P($G(^("TPB")),"^",5)'=0) Q
- .S $P(^PSRX(PSOTPPX3,"TPB"),"^")=1,PSOTPPX9=1
- I PSOTPPX9 K DA,DIE,DR S DIE="^PS(52.91,",DA=PSOTPPX,DR="2////"_"@"_";3////"_"@" D ^DIE K DIE,DA,DR
- Q
- ;
- SCH ;DBIA to return TPB patients to Scheduling
- N PSOSCT,PSOSCTD
- K ^TMP($J,"PSODFN")
- F PSOSCT=0:0 S PSOSCT=$O(^PS(52.91,PSOSCT)) Q:'PSOSCT I PSOSCT=$P($G(^(PSOSCT,0)),"^") D
- .S PSOSCTD=$P($G(^PS(52.91,PSOSCT,0)),"^",3)
- .I 'PSOSCTD!(PSOSCTD>DT) D
- ..I $P($G(^DPT(PSOSCT,0)),"^")="" Q
- ..S ^TMP($J,"PSODFN",$P($G(^DPT(PSOSCT,0)),"^"),PSOSCT)=""
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOTPCAN 7901 printed Feb 19, 2025@00:02:10 Page 2
- PSOTPCAN ;BIR/RTR - TPB Utility routine ;08/23/03
- +1 ;;7.0;OUTPATIENT PHARMACY;**146,153,163,227**;DEC 1997
- +2 ;External reference to PS(55 supported by DBIA 2228
- +3 ;External reference to VA(200 supported by DBIA 224
- +4 ;
- +5 ;Check Rx being DC'd, if it's a TPB Rx, check to inactivate patient
- +6 ;Called from all DC actions
- CAN(PSOTPRCX) ;
- +1 ; placed out of order by PSO*7*227
- QUIT
- +2 IF '$GET(PSOTPRCX)
- QUIT
- +3 NEW PSOTPRC
- +4 SET PSOTPRC=$PIECE($GET(^PSRX(PSOTPRCX,0)),"^",2)
- +5 IF '$GET(PSOTPRC)
- QUIT
- +6 IF '$PIECE($GET(^PSRX(PSOTPRCX,"TPB")),"^")
- QUIT
- +7 IF '$DATA(^PS(52.91,PSOTPRC,0))
- QUIT
- +8 IF $PIECE($GET(^PS(52.91,PSOTPRC,0)),"^",3)
- IF $PIECE($GET(^(0)),"^",3)'>DT
- QUIT
- +9 ;Patient is active in the TPB File, and TPB Rx is being canceled
- +10 IF PSOTPRC'=$PIECE($GET(^PSRX(PSOTPRCX,0)),"^",2)
- QUIT
- +11 NEW PSOTPCSS,PSOTCXFL,PSOTC1,PSOTC2,PSOTC3,X1,X2,DA,DR,DIE,X,Y
- +12 SET PSOTCXFL=0
- +13 SET X1=DT
- SET X2=-1
- DO C^%DTC
- SET PSOTC3=X
- +14 FOR PSOTC1=PSOTC3:0
- SET PSOTC1=$ORDER(^PS(55,PSOTPRC,"P","A",PSOTC1))
- if 'PSOTC1!(PSOTCXFL)
- QUIT
- SET PSOTC2=""
- FOR
- SET PSOTC2=$ORDER(^PS(55,PSOTPRC,"P","A",PSOTC1,PSOTC2))
- if PSOTC2=""!(PSOTCXFL)
- QUIT
- Begin DoDot:1
- +15 IF $PIECE($GET(^PSRX(PSOTC2,0)),"^",2)'=PSOTPRC
- QUIT
- +16 SET PSOTPCSS=$PIECE($GET(^PSRX(PSOTC2,"STA")),"^")
- +17 IF PSOTPCSS'=0
- IF PSOTPCSS'=1
- IF PSOTPCSS'=2
- IF PSOTPCSS'=3
- IF PSOTPCSS'=4
- IF PSOTPCSS'=5
- IF PSOTPCSS'=16
- QUIT
- +18 IF $PIECE($GET(^PSRX(PSOTC2,"TPB")),"^")
- IF $PIECE($GET(^(2)),"^",6)'<DT
- SET PSOTCXFL=1
- End DoDot:1
- +19 IF 'PSOTCXFL
- KILL DA,DIE,DR
- SET DA=PSOTPRC
- SET DIE="^PS(52.91,"
- SET DR="2////"_DT_";3////"_6
- DO ^DIE
- KILL DIE,DA,DR
- +20 QUIT
- +21 ;
- MARK ;Mark Rx as TPB Rx if applicable
- +1 NEW PSOTPODE,PSOZTRX
- +2 IF '$GET(PSOX("IRXN"))
- QUIT
- +3 IF '$DATA(^PSRX(PSOX("IRXN"),0))
- QUIT
- +4 IF '$GET(PSOTPBFG)
- QUIT
- +5 ;I $G(PSOFDR) Q
- +6 SET PSOTPODE=$GET(^PSRX(PSOX("IRXN"),0))
- +7 IF '$PIECE(PSOTPODE,"^",2)!('$PIECE(PSOTPODE,"^",3))!('$PIECE(PSOTPODE,"^",4))
- QUIT
- +8 SET PSOZTRX=$PIECE($GET(^PS(53,+$PIECE(PSOTPODE,"^",3),0)),"^")
- IF $$UP^XLFSTR(PSOZTRX)'="NON-VA"
- QUIT
- +9 IF '$PIECE($GET(^VA(200,+$PIECE(PSOTPODE,"^",4),"TPB")),"^")
- QUIT
- +10 IF $PIECE($GET(^VA(200,+$PIECE(PSOTPODE,"^",4),"TPB")),"^",5)'=0
- QUIT
- +11 IF '$DATA(^PS(52.91,+$PIECE(PSOTPODE,"^",2),0))
- QUIT
- +12 IF $PIECE($GET(^PS(52.91,+$PIECE(PSOTPODE,"^",2),0)),"^",3)
- IF $PIECE($GET(^(0)),"^",3)'>DT
- QUIT
- +13 ;Hard setting, to avoid DIE kiling any needed variables, no cross references on field, if added, need to use FileMan here
- +14 SET $PIECE(^PSRX(PSOX("IRXN"),"TPB"),"^")=1
- +15 QUIT
- MARKV ;Mark from Verify action
- +1 NEW PSOTPV1,PSOTPV2
- +2 IF '$GET(PSONVLP)
- QUIT
- +3 IF '$DATA(^PSRX(PSONVLP,0))
- QUIT
- +4 IF '$GET(PSOTPBFG)
- QUIT
- +5 ;I $G(PSOFDR) Q
- +6 SET PSOTPV1=$GET(^PSRX(PSONVLP,0))
- +7 IF '$PIECE(PSOTPV1,"^",2)!('$PIECE(PSOTPV1,"^",3))!('$PIECE(PSOTPV1,"^",4))
- QUIT
- +8 SET PSOTPV2=$PIECE($GET(^PS(53,+$PIECE(PSOTPV1,"^",3),0)),"^")
- IF $$UP^XLFSTR(PSOTPV2)'="NON-VA"
- QUIT
- +9 IF '$PIECE($GET(^VA(200,+$PIECE(PSOTPV1,"^",4),"TPB")),"^")
- QUIT
- +10 IF $PIECE($GET(^VA(200,+$PIECE(PSOTPV1,"^",4),"TPB")),"^",5)'=0
- QUIT
- +11 IF '$DATA(^PS(52.91,+$PIECE(PSOTPV1,"^",2),0))
- QUIT
- +12 IF $PIECE($GET(^PS(52.91,+$PIECE(PSOTPV1,"^",2),0)),"^",3)
- IF $PIECE($GET(^(0)),"^",3)'>DT
- QUIT
- +13 SET $PIECE(^PSRX(PSONVLP,"TPB"),"^")=1
- +14 QUIT
- RXPAT ;Sets Rx patient status to null
- +1 NEW PSOZZTRX
- +2 IF $GET(X)
- IF $GET(X)'>DT
- Begin DoDot:1
- +3 SET PSOZZTRX=$PIECE($GET(^PS(53,+$PIECE($GET(^PS(55,DA,"PS")),"^"),0)),"^")
- SET PSOZZTRX=$$UP^XLFSTR(PSOZZTRX)
- IF PSOZZTRX="NON-VA"
- SET $PIECE(^PS(55,DA,"PS"),"^")=""
- End DoDot:1
- +4 QUIT
- SET(PSOTPPST) ;Pass in DFN on a hard set of INACTIVATION OF BENEFIT DATE
- +1 NEW PSOZXTRX
- +2 IF $PIECE($GET(^PS(52.91,PSOTPPST,0)),"^",3)
- IF $PIECE($GET(^(0)),"^",3)'>DT
- SET PSOZXTRX=$PIECE($GET(^PS(53,+$PIECE($GET(^PS(55,PSOTPPST,"PS")),"^"),0)),"^")
- IF $$UP^XLFSTR(PSOZXTRX)="NON-VA"
- SET $PIECE(^PS(55,PSOTPPST,"PS"),"^")=""
- +3 QUIT
- PCAP(PSOPAPPT) ;Find nearest Primary Care appointment
- +1 QUIT "TODAY AT NOON"
- +2 ;
- PDIR(PSOTPEX) ;
- +1 if '$GET(PSOTPEX)
- QUIT
- +2 NEW PSOTPEXS
- +3 SET PSOTPEXT=0
- +4 SET PSOTPEXS=$PIECE($GET(^DPT(PSOTPEX,0)),"^",9)
- +5 WRITE !!?10,$CHAR(7),$PIECE($GET(^DPT(PSOTPEX,0)),"^")_" ("_$EXTRACT(PSOTPEXS,1,3)_"-"_$EXTRACT(PSOTPEXS,4,5)_"-"_$EXTRACT(PSOTPEXS,6,9)_")"
- +6 WRITE !?10,"Patient is eligible for the Transitional Pharmacy Benefit!!"
- +7 WRITE !
- KILL DIR
- SET DIR(0)="E"
- SET DIR("A")="Press <ret> to continue, '^' to exit"
- DO ^DIR
- KILL DIR
- IF Y'=1
- SET PSOTPEXT=1
- +8 QUIT
- VOPN ;
- +1 IF '$GET(PSOTPPEN)
- QUIT
- +2 IF '$DATA(^PSRX(PSOTPPEN,0))
- QUIT
- +3 NEW PSOTPPE3,PSOTPPE4,PSOTPPE5,PSOTPPE6,PSOTPPE7,PSOTPPE8
- +4 SET PSOTPPE6=1
- +5 SET PSOTPPE3=$PIECE($GET(^PSRX(PSOTPPEN,0)),"^",3)
- SET PSOTPPE4=$PIECE($GET(^PSRX(PSOTPPEN,0)),"^",4)
- VOPNX ;
- +1 IF 'PSOTPPE4
- SET PSOTPPEX=1
- SET PSOTPPE5(PSOTPPE6)="Unknown Provider!"
- SET PSOTPPE6=PSOTPPE6+1
- +2 IF 'PSOTPPE3
- SET PSOTPPEX=1
- SET PSOTPPE5(PSOTPPE6)="Unknown Patient Status!"
- SET PSOTPPE6=PSOTPPE6+1
- +3 IF PSOTPPE4
- IF '$PIECE($GET(^VA(200,PSOTPPE4,"TPB")),"^")
- SET PSOTPPE5(PSOTPPE6)="Provider is not flagged as a NON-VA PRESCRIBER!"
- SET PSOTPPE6=PSOTPPE6+1
- SET PSOTPPEX=1
- +4 IF PSOTPPE4
- IF $PIECE($GET(^VA(200,PSOTPPE4,"TPB")),"^",5)'=0
- SET PSOTPPE5(PSOTPPE6)="Provider is not flagged as not being on exclusionary list!"
- SET PSOTPPE6=PSOTPPE6+1
- SET PSOTPPEX=1
- +5 IF PSOTPPE3
- SET PSOTPPE7=$PIECE($GET(^PS(53,PSOTPPE3,0)),"^")
- SET PSOTPPE7=$$UP^XLFSTR(PSOTPPE7)
- IF PSOTPPE7'="NON-VA"
- SET PSOTPPE5(PSOTPPE6)="Rx Patient Status is not equal to 'NON-VA'!"
- SET PSOTPPE6=PSOTPPE6+1
- SET PSOTPPEX=1
- +6 IF $GET(PSOTPPEX)
- Begin DoDot:1
- +7 WRITE !
- FOR PSOTPPE8=0:0
- SET PSOTPPE8=$ORDER(PSOTPPE5(PSOTPPE8))
- if 'PSOTPPE8
- QUIT
- WRITE !,$GET(PSOTPPE5(PSOTPPE8))
- +8 KILL DIR
- SET DIR(0)="E"
- SET DIR("A")="Press Return to continue"
- DO ^DIR
- KILL DIR
- End DoDot:1
- IF $GET(PSOTPPE9)
- SET VALMSG="Cannot Verify through this option"
- +9 QUIT
- VOPNR ;
- +1 IF '$GET(PSOTPPEN)
- QUIT
- +2 IF '$DATA(^PS(52.41,PSOTPPEN,0))
- QUIT
- +3 NEW PSOTPPE3,PSOTPPE4,PSOTPPE5,PSOTPPE6,PSOTPPE7,PSOTPPE8
- +4 SET PSOTPPE6=1
- +5 IF $PIECE(^PS(52.41,PSOTPPEN,0),"^",3)="RNW"
- IF $DATA(^PSRX(+$PIECE(^PS(52.41,PSOTPPEN,0),"^",21),0))
- SET PSOTPPE3=$PIECE($GET(^PSRX(+$PIECE(^PS(52.41,PSOTPPEN,0),"^",21),0)),"^",3)
- GOTO NOREN
- +6 SET PSOTPPE3=$PIECE($GET(^PS(55,+$PIECE($GET(^PS(52.41,PSOTPPEN,0)),"^",2),"PS")),"^")
- NOREN ;
- +1 SET PSOTPPE4=$PIECE($GET(^PS(52.41,PSOTPPEN,0)),"^",5)
- +2 GOTO VOPNX
- +3 ;
- DSPL(PSOTPWRN) ;
- +1 NEW DIR,PSOTPWR1,PSOTPWR2,PSOTPWR3
- +2 IF '$GET(PSOTPWRN)
- QUIT
- +3 IF '$DATA(^PS(52.41,PSOTPWRN,0))
- QUIT
- +4 IF $PIECE(^PS(52.41,PSOTPWRN,0),"^",3)="RNW"
- IF $DATA(^PSRX(+$PIECE(^PS(52.41,PSOTPWRN,0),"^",21),0))
- Begin DoDot:1
- +5 SET PSOTPWR1=$PIECE($GET(^PSRX(+$PIECE(^PS(52.41,PSOTPWRN,0),"^",21),0)),"^",3)
- +6 SET PSOTPWR2=$PIECE($GET(^PS(53,+PSOTPWR1,0)),"^")
- SET PSOTPWR3=$$UP^XLFSTR(PSOTPWR2)
- +7 IF PSOTPWR3="NON-VA"
- Begin DoDot:2
- +8 KILL DIR
- WRITE !!,"This order has an Rx Patient Status of 'NON-VA'!",!
- KILL DIR
- SET DIR(0)="E"
- SET DIR("A")="Press return to continue"
- DO ^DIR
- KILL DIR
- +9 QUIT
- End DoDot:2
- +10 QUIT
- End DoDot:1
- QUIT
- +11 SET PSOTPWR1=$PIECE($GET(^PS(55,+$PIECE($GET(^PS(52.41,PSOTPWRN,0)),"^",2),"PS")),"^")
- +12 SET PSOTPWR2=$PIECE($GET(^PS(53,+PSOTPWR1,0)),"^")
- SET PSOTPWR3=$$UP^XLFSTR(PSOTPWR2)
- +13 IF PSOTPWR3="NON-VA"
- Begin DoDot:1
- +14 WRITE !!,"This order has an Rx Patient Status of 'NON-VA'!",!
- KILL DIR
- SET DIR(0)="E"
- SET DIR("A")="Press return to continue"
- DO ^DIR
- KILL DIR
- End DoDot:1
- +15 QUIT
- EXFLAG(PSOTPPX) ;Exit TPB RX option, reset TPG flag if necessary,
- +1 ;and possibly delete inactive date and reason code for patient in 52.91
- +2 IF '$GET(DT)
- SET DT=$$DT^XLFDT
- +3 IF '$GET(PSOTPPX)
- QUIT
- +4 IF '$DATA(^PS(52.91,PSOTPPX,0))
- QUIT
- +5 IF $EXTRACT($PIECE(^PS(52.91,PSOTPPX,0),"^",3),1,7)'=DT
- QUIT
- +6 IF $PIECE(^PS(52.91,PSOTPPX,0),"^",4)'=6
- QUIT
- +7 NEW DR,DIE,X1,X2,X,Y,DA,PSOTPPX1,PSOTPPX2,PSOTPPX3,PSOTPPX4,PSOTPPX5,PSOTPPX6,PSOTPPX7,PSOTPPX9
- +8 SET X1=DT
- SET X2=-1
- DO C^%DTC
- SET PSOTPPX1=X
- +9 SET PSOTPPX9=0
- +10 FOR PSOTPPX2=PSOTPPX1:0
- SET PSOTPPX2=$ORDER(^PS(55,PSOTPPX,"P","A",PSOTPPX2))
- if 'PSOTPPX2
- QUIT
- SET PSOTPPX3=""
- FOR
- SET PSOTPPX3=$ORDER(^PS(55,PSOTPPX,"P","A",PSOTPPX2,PSOTPPX3))
- if PSOTPPX3=""
- QUIT
- Begin DoDot:1
- +11 IF PSOTPPX'=$PIECE($GET(^PSRX(PSOTPPX3,0)),"^",2)
- QUIT
- +12 IF $PIECE($GET(^PSRX(PSOTPPX3,"TPB")),"^")
- QUIT
- +13 IF $EXTRACT($PIECE($GET(^PSRX(PSOTPPX3,2)),"^"),1,7)'=DT
- QUIT
- +14 SET PSOTPPX4=$PIECE($GET(^PSRX(PSOTPPX3,"STA")),"^")
- IF PSOTPPX4=""
- QUIT
- +15 IF PSOTPPX4'=0
- IF PSOTPPX4'=1
- IF PSOTPPX4'=2
- IF PSOTPPX4'=3
- IF PSOTPPX4'=4
- IF PSOTPPX4'=5
- IF PSOTPPX4'=16
- QUIT
- +16 SET PSOTPPX5=$PIECE(^PSRX(PSOTPPX3,0),"^",3)
- SET PSOTPPX6=$PIECE(^(0),"^",4)
- +17 IF 'PSOTPPX5!('PSOTPPX6)
- QUIT
- +18 SET PSOTPPX7=$PIECE($GET(^PS(53,+PSOTPPX5,0)),"^")
- SET PSOTPPX7=$$UP^XLFSTR(PSOTPPX7)
- IF PSOTPPX7'="NON-VA"
- QUIT
- +19 IF '$PIECE($GET(^VA(200,PSOTPPX6,"TPB")),"^")!($PIECE($GET(^("TPB")),"^",5)'=0)
- QUIT
- +20 SET $PIECE(^PSRX(PSOTPPX3,"TPB"),"^")=1
- SET PSOTPPX9=1
- End DoDot:1
- +21 IF PSOTPPX9
- KILL DA,DIE,DR
- SET DIE="^PS(52.91,"
- SET DA=PSOTPPX
- SET DR="2////"_"@"_";3////"_"@"
- DO ^DIE
- KILL DIE,DA,DR
- +22 QUIT
- +23 ;
- SCH ;DBIA to return TPB patients to Scheduling
- +1 NEW PSOSCT,PSOSCTD
- +2 KILL ^TMP($JOB,"PSODFN")
- +3 FOR PSOSCT=0:0
- SET PSOSCT=$ORDER(^PS(52.91,PSOSCT))
- if 'PSOSCT
- QUIT
- IF PSOSCT=$PIECE($GET(^(PSOSCT,0)),"^")
- Begin DoDot:1
- +4 SET PSOSCTD=$PIECE($GET(^PS(52.91,PSOSCT,0)),"^",3)
- +5 IF 'PSOSCTD!(PSOSCTD>DT)
- Begin DoDot:2
- +6 IF $PIECE($GET(^DPT(PSOSCT,0)),"^")=""
- QUIT
- +7 SET ^TMP($JOB,"PSODFN",$PIECE($GET(^DPT(PSOSCT,0)),"^"),PSOSCT)=""
- End DoDot:2
- End DoDot:1
- +8 QUIT