- PSOSUCH1 ;BHAM ISC/JMB-Change suspense and fill/refill dates ; 4/49/93
- ;;7.0;OUTPATIENT PHARMACY;**148,681**;DEC 1997;Build 11
- ;
- LISTSUS S X="?",DIC("S")="I $D(^PSRX(+$P(^PS(52.5,+Y,0),""^""),0)),$P($G(^(""STA"")),""^"")<11,$P($G(^PS(52.5,+Y,""P"")),""^"")=0",DIC="^PS(52.5,",DIC(0)="ZQ" D ^DIC K DIC W ! Q:Y<0!($D(DTOUT)) Q
- ;
- LISTPAT S X="?",DIC(0)="EMQ",DIC="^DPT(",DIC("S")="I $D(^PS(52.5,""AC"",+Y))" D ^DIC K DIC Q
- ;
- PSOINST S PSOINST=$P($G(^DIC(4,+$P($G(^XMB(1,1,"XUS")),"^",17),99)),"^") I Y["-",'$D(^PSRX($P(Y,"-",2),0)) W !,?7,$C(7),$C(7),$C(7)," NON-EXISTENT PRESCRIPTION" G SPEC^PSOSUCHG:ACT="S" G ALL^PSOSUCHG:ACT="A"
- I Y["-",$P(Y,"-")'=PSOINST W !,?7,$C(7),$C(7),$C(7)," NOT FROM THIS INSTITUTION" G SPEC^PSOSUCHG:ACT="S" G ALL^PSOSUCHG:ACT="A"
- Q
- ;
- AREC ;
- N PSODUZ
- S PSODUZ=DUZ
- I '$D(^VA(200,+PSODUZ,0)) S PSODUZ=.5
- I 'DEAD S COM="Change "_$S($G(PSOSUSPA):"Partial",'$G(SUB):"Fill",1:"Refill")_" Date "_$E(OLD,4,5)_"/"_$E(OLD,6,7)_"/"_$E(OLD,2,3)_" to "_$E(INDT,4,5)_"/"_$E(INDT,6,7)_"/"_$E(INDT,2,3)
- S CNT=0 F SUB=0:0 S SUB=$O(^PSRX(RXREC,"A",SUB)) Q:'SUB S CNT=SUB
- S RFCNT=0 F RF=0:0 S RF=$O(^PSRX(RXREC,1,RF)) Q:'RF S RFCNT=RF S:RF>5 RFCNT=RF+1
- D NOW^%DTC
- S CNT=CNT+1
- S ^PSRX(RXREC,"A",0)="^52.3DA^"_CNT_"^"_CNT
- S ^PSRX(RXREC,"A",CNT,0)=%_"^"_$S(DEAD:"C",1:"S")_"^"_PSODUZ_"^"_$S($G(PSOSUSPA):6,1:RFCNT)_"^"_COM
- K PSOSUSPA
- Q
- ;
- CHKDEAD D DEM^VADPT I VADM(1)="" W !?10,"PATIENT NAME UNKNOWN" S DEAD=0 Q
- I VADM(6)="" S DEAD=0 Q
- S SUSDOD=$P(VADM(6),"^",2)
- F RXREC=0:0 S RXREC=$O(^PS(52.5,"AC",DFN,RXREC)) Q:'RXREC F SRXREC=0:0 S SRXREC=$O(^PS(52.5,"AC",DFN,RXREC,SRXREC)) Q:'SRXREC S RECORD=$P($G(^PS(52.5,SRXREC,0)),"^") D:RECORD DEAD
- Q
- ;
- DEAD S HOLD=$G(DA),REA="C",COM="Died ("_$G(SUSDOD)_")",DA=RECORD,DEAD=1 D CAN^PSOCAN
- W:'WARN !!,?10,$P($G(^DPT(DFN,0)),"^")_" DIED "_SUSDOD_" all prescriptions were discontinued" W:'WARN !,?15," and deleted from the suspense file." S WARN=1,DA=HOLD K HOLD,REA
- Q
- ;
- NEXT S PSOX("IRXN")=RXREC D NEXT^PSOUTIL(.PSOX) S NEXT=$P(PSOX("RX3"),"^",2),DA=RXREC,DIE=52,DR="102///"_NEXT D ^DIE K DIE Q:$D(DTOUT)!($D(DUOUT))
- K NEXT,PSOX Q
- ;
- CHANGE(RXREC,SUB) ; File update for Suspense Date change
- I $P($G(^PS(52.5,SFN,0)),"^",5) S PSOSUSPA=1,HDSFN=SFN S SRXPAR=+$P(^(0),"^",5),OLD=+$P($G(^PSRX(RXREC,"P",SRXPAR,0)),"^"),DA(1)=RXREC,DA=SRXPAR,DIE="^PSRX("_DA(1)_",""P"",",DR=".01////"_INDT D ^DIE G FIN
- I '$D(SUB) S SUB=0 F II=0:0 S II=$O(^PSRX(RXREC,1,II)) Q:'II S SUB=+II
- S HDSFN=SFN I 'SUB S (X,OLD)=$P(^PSRX(RXREC,2),"^",2),DA=RXREC,DR="22///"_INDT_";101///"_INDT,DIE=52 D
- .D ^DIE K DIE K:$G(^PS(52.5,HDSFN,"P"))=1 ^PS(52.5,"AC",DFN,+$P($G(^PS(52.5,HDSFN,0)),"^",2),HDSFN) Q:$D(DTOUT)!($D(DUOUT)) D NEXT K DA Q
- I SUB S (OLD,X)=+$P($G(^PSRX(RXREC,1,SUB,0)),"^"),DA(1)=RXREC,DA=SUB,DIE="^PSRX("_DA(1)_",1,",DR=".01///"_INDT D ^DIE K DIE S $P(^PSRX(RXREC,3),"^")=INDT D
- .K:$G(^PS(52.5,HDSFN,"P"))=1 ^PS(52.5,"AC",DFN,+$P($G(^PS(52.5,HDSFN,0)),"^",2),HDSFN) D NEXT S DA=RXREC K DA Q
- ;
- FIN S DA=HDSFN,DIK="^PS(52.5," D IX1^DIK
- S SFN=HDSFN D AREC N X S X="PSXCH" X ^%ZOSF("TEST") K X Q:'$T D:$G(XOK)=1 X^PSXCH Q
- Q
- ;
- DAREC ;
- N PSODUZ
- S PSODUZ=DUZ
- I '$D(^VA(200,+PSODUZ,0)) S PSODUZ=.5
- S SCOM="Rx "_$S($P(SNODE,"^",5):"(Partial) ",1:"")_"deleted from suspense"
- S SSX=0 F SSXX=0:0 S SSXX=$O(^PSRX(RXREC,"A",SSXX)) Q:'SSXX S SSX=SSXX
- S SXCNT=0 F SCXX=0:0 S SCXX=$O(^PSRX(RXREC,1,SCXX)) Q:'SCXX S SXCNT=SCXX S:SCXX>5 SXCNT=SCXX+1
- D NOW^%DTC
- S SSX=SSX+1
- S ^PSRX(RXREC,"A",0)="^52.3DA^"_SSX_"^"_SSX
- S ^PSRX(RXREC,"A",SSX,0)=%_"^"_"S"_"^"_PSODUZ_"^"_$S($P(SNODE,"^",5):6,1:SXCNT)_"^"_SCOM
- K SCOM,SSX,SSXX,SXCNT,SCXX
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOSUCH1 3674 printed Apr 23, 2025@18:49:47 Page 2
- PSOSUCH1 ;BHAM ISC/JMB-Change suspense and fill/refill dates ; 4/49/93
- +1 ;;7.0;OUTPATIENT PHARMACY;**148,681**;DEC 1997;Build 11
- +2 ;
- LISTSUS SET X="?"
- SET DIC("S")="I $D(^PSRX(+$P(^PS(52.5,+Y,0),""^""),0)),$P($G(^(""STA"")),""^"")<11,$P($G(^PS(52.5,+Y,""P"")),""^"")=0"
- SET DIC="^PS(52.5,"
- SET DIC(0)="ZQ"
- DO ^DIC
- KILL DIC
- WRITE !
- if Y<0!($DATA(DTOUT))
- QUIT
- QUIT
- +1 ;
- LISTPAT SET X="?"
- SET DIC(0)="EMQ"
- SET DIC="^DPT("
- SET DIC("S")="I $D(^PS(52.5,""AC"",+Y))"
- DO ^DIC
- KILL DIC
- QUIT
- +1 ;
- PSOINST SET PSOINST=$PIECE($GET(^DIC(4,+$PIECE($GET(^XMB(1,1,"XUS")),"^",17),99)),"^")
- IF Y["-"
- IF '$DATA(^PSRX($PIECE(Y,"-",2),0))
- WRITE !,?7,$CHAR(7),$CHAR(7),$CHAR(7)," NON-EXISTENT PRESCRIPTION"
- if ACT="S"
- GOTO SPEC^PSOSUCHG
- if ACT="A"
- GOTO ALL^PSOSUCHG
- +1 IF Y["-"
- IF $PIECE(Y,"-")'=PSOINST
- WRITE !,?7,$CHAR(7),$CHAR(7),$CHAR(7)," NOT FROM THIS INSTITUTION"
- if ACT="S"
- GOTO SPEC^PSOSUCHG
- if ACT="A"
- GOTO ALL^PSOSUCHG
- +2 QUIT
- +3 ;
- AREC ;
- +1 NEW PSODUZ
- +2 SET PSODUZ=DUZ
- +3 IF '$DATA(^VA(200,+PSODUZ,0))
- SET PSODUZ=.5
- +4 IF 'DEAD
- SET COM="Change "_$SELECT($GET(PSOSUSPA):"Partial",'$GET(SUB):"Fill",1:"Refill")_" Date "_$EXTRACT(OLD,4,5)_"/"_$EXTRACT(OLD,6,7)_"/"_$EXTRACT(OLD,2,3)_" to "_$EXTRACT(INDT,4,5)_"/"_$EXTRACT(INDT,6,7)_"/"_$EXTRACT(INDT,2,3)
- +5 SET CNT=0
- FOR SUB=0:0
- SET SUB=$ORDER(^PSRX(RXREC,"A",SUB))
- if 'SUB
- QUIT
- SET CNT=SUB
- +6 SET RFCNT=0
- FOR RF=0:0
- SET RF=$ORDER(^PSRX(RXREC,1,RF))
- if 'RF
- QUIT
- SET RFCNT=RF
- if RF>5
- SET RFCNT=RF+1
- +7 DO NOW^%DTC
- +8 SET CNT=CNT+1
- +9 SET ^PSRX(RXREC,"A",0)="^52.3DA^"_CNT_"^"_CNT
- +10 SET ^PSRX(RXREC,"A",CNT,0)=%_"^"_$SELECT(DEAD:"C",1:"S")_"^"_PSODUZ_"^"_$SELECT($GET(PSOSUSPA):6,1:RFCNT)_"^"_COM
- +11 KILL PSOSUSPA
- +12 QUIT
- +13 ;
- CHKDEAD DO DEM^VADPT
- IF VADM(1)=""
- WRITE !?10,"PATIENT NAME UNKNOWN"
- SET DEAD=0
- QUIT
- +1 IF VADM(6)=""
- SET DEAD=0
- QUIT
- +2 SET SUSDOD=$PIECE(VADM(6),"^",2)
- +3 FOR RXREC=0:0
- SET RXREC=$ORDER(^PS(52.5,"AC",DFN,RXREC))
- if 'RXREC
- QUIT
- FOR SRXREC=0:0
- SET SRXREC=$ORDER(^PS(52.5,"AC",DFN,RXREC,SRXREC))
- if 'SRXREC
- QUIT
- SET RECORD=$PIECE($GET(^PS(52.5,SRXREC,0)),"^")
- if RECORD
- DO DEAD
- +4 QUIT
- +5 ;
- DEAD SET HOLD=$GET(DA)
- SET REA="C"
- SET COM="Died ("_$GET(SUSDOD)_")"
- SET DA=RECORD
- SET DEAD=1
- DO CAN^PSOCAN
- +1 if 'WARN
- WRITE !!,?10,$PIECE($GET(^DPT(DFN,0)),"^")_" DIED "_SUSDOD_" all prescriptions were discontinued"
- if 'WARN
- WRITE !,?15," and deleted from the suspense file."
- SET WARN=1
- SET DA=HOLD
- KILL HOLD,REA
- +2 QUIT
- +3 ;
- NEXT SET PSOX("IRXN")=RXREC
- DO NEXT^PSOUTIL(.PSOX)
- SET NEXT=$PIECE(PSOX("RX3"),"^",2)
- SET DA=RXREC
- SET DIE=52
- SET DR="102///"_NEXT
- DO ^DIE
- KILL DIE
- if $DATA(DTOUT)!($DATA(DUOUT))
- QUIT
- +1 KILL NEXT,PSOX
- QUIT
- +2 ;
- CHANGE(RXREC,SUB) ; File update for Suspense Date change
- +1 IF $PIECE($GET(^PS(52.5,SFN,0)),"^",5)
- SET PSOSUSPA=1
- SET HDSFN=SFN
- SET SRXPAR=+$PIECE(^(0),"^",5)
- SET OLD=+$PIECE($GET(^PSRX(RXREC,"P",SRXPAR,0)),"^")
- SET DA(1)=RXREC
- SET DA=SRXPAR
- SET DIE="^PSRX("_DA(1)_",""P"","
- SET DR=".01////"_INDT
- DO ^DIE
- GOTO FIN
- +2 IF '$DATA(SUB)
- SET SUB=0
- FOR II=0:0
- SET II=$ORDER(^PSRX(RXREC,1,II))
- if 'II
- QUIT
- SET SUB=+II
- +3 SET HDSFN=SFN
- IF 'SUB
- SET (X,OLD)=$PIECE(^PSRX(RXREC,2),"^",2)
- SET DA=RXREC
- SET DR="22///"_INDT_";101///"_INDT
- SET DIE=52
- Begin DoDot:1
- +4 DO ^DIE
- KILL DIE
- if $GET(^PS(52.5,HDSFN,"P"))=1
- KILL ^PS(52.5,"AC",DFN,+$PIECE($GET(^PS(52.5,HDSFN,0)),"^",2),HDSFN)
- if $DATA(DTOUT)!($DATA(DUOUT))
- QUIT
- DO NEXT
- KILL DA
- QUIT
- End DoDot:1
- +5 IF SUB
- SET (OLD,X)=+$PIECE($GET(^PSRX(RXREC,1,SUB,0)),"^")
- SET DA(1)=RXREC
- SET DA=SUB
- SET DIE="^PSRX("_DA(1)_",1,"
- SET DR=".01///"_INDT
- DO ^DIE
- KILL DIE
- SET $PIECE(^PSRX(RXREC,3),"^")=INDT
- Begin DoDot:1
- +6 if $GET(^PS(52.5,HDSFN,"P"))=1
- KILL ^PS(52.5,"AC",DFN,+$PIECE($GET(^PS(52.5,HDSFN,0)),"^",2),HDSFN)
- DO NEXT
- SET DA=RXREC
- KILL DA
- QUIT
- End DoDot:1
- +7 ;
- FIN SET DA=HDSFN
- SET DIK="^PS(52.5,"
- DO IX1^DIK
- +1 SET SFN=HDSFN
- DO AREC
- NEW X
- SET X="PSXCH"
- XECUTE ^%ZOSF("TEST")
- KILL X
- if '$TEST
- QUIT
- if $GET(XOK)=1
- DO X^PSXCH
- QUIT
- +2 QUIT
- +3 ;
- DAREC ;
- +1 NEW PSODUZ
- +2 SET PSODUZ=DUZ
- +3 IF '$DATA(^VA(200,+PSODUZ,0))
- SET PSODUZ=.5
- +4 SET SCOM="Rx "_$SELECT($PIECE(SNODE,"^",5):"(Partial) ",1:"")_"deleted from suspense"
- +5 SET SSX=0
- FOR SSXX=0:0
- SET SSXX=$ORDER(^PSRX(RXREC,"A",SSXX))
- if 'SSXX
- QUIT
- SET SSX=SSXX
- +6 SET SXCNT=0
- FOR SCXX=0:0
- SET SCXX=$ORDER(^PSRX(RXREC,1,SCXX))
- if 'SCXX
- QUIT
- SET SXCNT=SCXX
- if SCXX>5
- SET SXCNT=SCXX+1
- +7 DO NOW^%DTC
- +8 SET SSX=SSX+1
- +9 SET ^PSRX(RXREC,"A",0)="^52.3DA^"_SSX_"^"_SSX
- +10 SET ^PSRX(RXREC,"A",SSX,0)=%_"^"_"S"_"^"_PSODUZ_"^"_$SELECT($PIECE(SNODE,"^",5):6,1:SXCNT)_"^"_SCOM
- +11 KILL SCOM,SSX,SSXX,SXCNT,SCXX
- +12 QUIT
