- PSODISPS ;BIR/SAB-CONTINUATION OF RELEASE FUNCTION ;05-Sep-2013 16:35;DU
- ;;7.0;OUTPATIENT PHARMACY;**15,13,9,27,67,71,1006,156,118,148,247,200,1015,1016**;DEC 1997;Build 74
- ;External reference ^PS(59.7 supported by DBIA 694
- ;External reference to ^PSDRUG("AQ" supported by DBIA 3165
- ;External reference ^XTMP("PSA" supported by DBIA 1036
- ;External reference $$SERV^IBARX1 supported by DBIA 2245
- ;External reference ^PSDRUG( supported by DBIA 221
- ;Reference to ^DIC(19.2 supported by DBIA 1064
- ;Modified - IHS/MSC/PLS - 10/22/07- Line QTY+6
- ; IHS/MSC/MGH - 05/02/2013 - Line OERR+4
- QTY ; Refill Release
- S PSOCPN=$P(^PSRX(RXP,0),"^",2),QDRUG=$P(^PSRX(RXP,0),"^",6) K LBLP
- F YY=0:0 S YY=$O(^PSRX(RXP,XTYPE,YY)) Q:'YY D:$P($G(^PSRX(RXP,XTYPE,YY,0)),"^")'<PSIN K ISUF,LBLP
- .S RXFD=$E($P(^PSRX(RXP,XTYPE,YY,0),"^"),1,7),SUPN=$O(^PS(52.5,"B",RXP,0)) I SUPN,$D(^PS(52.5,"C",RXFD,SUPN)),$G(^PS(52.5,SUPN,"P"))'=1,$G(XTYPE) S ISUF=1 Q
- .I XTYPE=1,($D(^PSDRUG("AQ",QDRUG))) K CMOP D RREL^PSOCMOPB(RXP,YY) K CMOP Q:$G(ISUF)
- .I $P(^PSRX(RXP,XTYPE,YY,0),"^",$S($G(XTYPE):18,1:19))]""!($P(^(0),"^",16)) K IFN Q
- .;
- .F LBL=0:0 S LBL=$O(^PSRX(RXP,"L",LBL)) Q:'LBL I $P(^PSRX(RXP,"L",LBL,0),"^",2)=$S('XTYPE:(99-YY),1:YY) S LBLP=1
- .Q:'$G(LBLP)
- .D CHKADDR(RXP)
- .;
- .; - Checking for OPEN/UNRESOLVED 3rd. Party Payer Rejects / NDC Editing
- .I XTYPE,$$MANREL^PSOBPSUT(RXP,YY,$G(PSOPID))="^" K LBLP Q
- .; IHS/MSC/PLS - 10/22/07 - suppress inventory mgmt if autofinished Rx.
- .;S IFN=YY S:$G(^PSDRUG(QDRUG,660.1))]"" QTY=$P(^PSRX(RXP,XTYPE,YY,0),"^",4),^PSDRUG(QDRUG,660.1)=^PSDRUG(QDRUG,660.1)-QTY
- .S IFN=YY S:$G(^PSDRUG(QDRUG,660.1))]"" QTY=$P(^PSRX(RXP,XTYPE,YY,0),"^",4),^PSDRUG(QDRUG,660.1)=^PSDRUG(QDRUG,660.1)-$S($P($G(^PSRX(RXP,999999921)),U,3):0,1:QTY)
- .K DA,DR,DIE D NOW^%DTC S DIE="^PSRX("_RXP_","""_XTYPE_""",",DA(1)=RXP
- .S DA=YY,DR=$S(XTYPE:17,1:8)_"///"_%_";"_$S(XTYPE:4,1:.05)_"////"_PSRH
- .S PSODT=% D ^DIE K DIE,DR,DA
- .;
- .; - Notifying IB through ECME of the Rx being released
- .I XTYPE D IBSEND^PSOBPSUT(RXP,YY)
- .;
- .K PSODISPP S:$G(XTYPE)="P" PSODISPP=1 D EN^PSOHLSN1(RXP,"ZD") K PSODISPP
- .K:XTYPE ^PSRX("ACP",$P($G(^PSRX(RXP,0)),"^",2),$P($G(^PSRX(RXP,1,YY,0)),"^"),YY,RXP)
- .I XTYPE,$G(IFN),'$G(ISUF) S PSOCPRX=$P(^PSRX(RXP,0),"^") D CP^PSOCP
- .;if appropriate update ^XTMP("PSA", for Drug Acct.
- .I $G(PSODA),$G(PSODA(1)),'$D(^PSRX("AR",+PSODT,+RXP,YY)) D
- ..S ^XTMP("PSA",+PSOSITE,+QDRUG,DT)=$G(^XTMP("PSA",+PSOSITE,+QDRUG,DT))+$P($G(^PSRX(RXP,XTYPE,YY,0)),"^",4)
- .;initialize bingo board variables
- .I $G(IFN),$P($G(^PSRX(RXP,XTYPE,IFN,0)),"^",2)["W" S BINGRPR="W",BNGPDV=$P(^PSRX(RXP,XTYPE,IFN,0),"^",9),BINGNAM=$P($G(^PSRX(RXP,0)),"^",2)
- W:$G(IFN) !?7,"Prescription Number "_$P(^PSRX(RXP,0),"^")_$S('$G(XTYPE):" Partial Fill",1:" Refill(s)")_" Released" I $G(SPEED) G XMIT
- W:'$G(IFN) !?7,"No "_$S($G(XTYPE):"Refill(s)",1:"Partial(s)")_" to be Released"
- XMIT I $G(PSODISP)=2.4 D ;build an send HL7 v2.4 messages to dispense system
- . F I=0:0 S SUB=$O(^PSRX(RXP,"A",I)) Q:'I I $P(^PSRX(RXP,"A",I,0),"^",2)="N" D
- .. D NOW^%DTC S PSODTM=% K ^UTILITY($J,"PSOHL")
- .. S IDGN=$P(^PSRX(+RXP,0),"^",6),FP=$S(XTYPE=1:"R",1:"P")
- .. S ^UTILITY($J,"PSOHL",1)=+RXP_"^"_IDGN_"^"_PSODTM_"^"_+$G(PDUZ)_"^0^^PSO DISP^^^"_FP_"^"_IFN
- .. S ZTRTN="INIT^PSORELDT",ZTDESC="EXTERNAL INTERFACE FOR RELEASE DATE/TIME",ZTIO="",ZTDTH=$H,ZTSAVE("^UTILITY($J,""PSOHL"",")="",ZTSAVE("PSOSITE")="",ZTSAVE("RXP")="" D ^%ZTLOAD K ^UTILITY($J,"PSOHL")
- K IFN
- Q
- STAT S RX0=^PSRX(RXP,0),$P(RX0,"^",15)=+^("STA"),RX2=^PSRX(RXP,2),J=RXP D ^PSOFUNC
- W !!?5,$C(7),$C(7),"Rx# "_$P(^PSRX(RXP,0),"^")_" has a status of "_ST_" and is not eligible for",!?5,"release."_$S('$D(^XUSEC("PSORPH",DUZ)):" Please check with a Pharmacist!",1:"")
- K RX0,ST
- Q
- OERR I '$D(PSOPAR) D ^PSOLSET I '$D(PSOPAR) W $C(7),!!,?5,"Site Parameters must be defined to use the Release option!",! S VALMBCK="" Q
- S VALMBCK="Q",Y=$G(^PS(59,PSOSITE,"IB")),PSOIBSS=$$SERV^IBARX1(+Y) I 'PSOIBSS D IBSSR^PSOUTL I 'PSOIBFL D S VALMBCK="" G EX
- .W $C(7),!!,"The IB SERVICE/SECTION defined in your site parameter file is not valid.",!,"You will not be able to release any medication until this is corrected!",!
- W !! S PSIN=+$P($G(^PS(59.7,1,49.99)),"^",2),RXP=$P(PSOLST($P(PSLST,",",ORD)),"^",2)
- ;S DIC("S")="I $D(^XUSEC(""PSORPH"",+Y))",DIC("A")="Enter PHARMACIST: ",DIC="^VA(200,",DIC(0)="QEAM" D ^DIC G:"^"[X EX K DIC G:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))!(Y=-1) EX S PSRH=+Y
- ;IHS/MSC/MGH Patch 1015 May 2,2013
- PHNAME S DIC("S")="I $D(^XUSEC(""PSORPH"",+Y))",DIC("A")="Enter PHARMACIST: ",DIC="^VA(200,",DIC(0)="QEAM"
- D ^DIC G:$L(X)=0 PHNAME G:"^"[X EX K DIC G:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))!(Y=-1) EX S PSRH=+Y
- ;END MOD
- OERR1 ;IHS/MSC/MGH 1016 Separated out for reissue code
- ;check for Drug Acct background job K8 & K7.1
- S X="PSA IV ALL LOCATIONS",DIC(0)="MZ",DIC=19.2 D ^DIC I Y=-1 K DIC,X,Y G DOIT
- I $P($G(Y(0)),U,2)>DT S PSODA=1 S:'$P($G(^XTMP("PSA",0)),U,2) $P(^(0),U,2)=DT G DOIT
- S X="PSA IV ALL LOCATIONS",DIC(0)="MZ",DIC=19 D ^DIC K DIC,X G:Y=-1 DOIT
- K DIQ,PSA S DA=+Y,DIC=19,DIQ="PSA",DR=200,DIQ(0)="IN" D EN^DIQ1
- I '$D(PSA(19,DA,200,"I")) K DIC,DA,X,Y,DIQ G DOIT
- I PSA(19,DA,200,"I")>DT S PSODA=1 S:'$P($G(^XTMP("PSA",0)),U,2) $P(^(0),U,2)=DT
- K PSA,DIC,DA,X,Y,DIQ
- ;
- DOIT S POERR=1 D FULL^VALM1,BC1^PSODISP
- I $D(DISGROUP),$D(BINGNAM),($D(BINGDIV)!$D(BNGPDV)!$D(BNGRDV)),($D(BINGRO)!$D(BINGRPR)) N TM,TM1 D REL^PSOBING1 K BINGNAM,BINGDIV,BINGRO,BINGRPR,BNGPDV,BNGRDV
- EX ;
- K OUT,RX2,RXFD,RESK,ISUF,SUPN,%,DIC,IFN,J,DA,DR,DIE,X,X1,X2,Y,RXP,CX,PX,REC,DIR,YDT,REC,RDUZ,DIRUT,PSOCPN,PSOCPRX,PSOIBSS,PSOIBFL,PSOIBLP,PSOIBST,YY,QDRUG,QTY,TYPE,XTYPE,DUOUT,PSRH,XX,Y,PSIN,POERR,SUB
- K DIR S DIR("A",1)=" ",DIR("A")="Press Return to Continue",DIR(0)="E" D ^DIR K DIRUT,DUOUT,DTOUT,DIR S VALMBCK="R"
- S PSORXED=1 D ^PSOBUILD,ACT^PSOORNE2 K PSORXED
- Q
- ;
- CHKADDR(RXP) ;
- N PSOTXT,PSOBADR,PSOTEMP,LBL
- S LBL=$O(^PSRX(RXP,"L",99999),-1) I LBL>0 D
- .S PSOTXT=$G(^PSRX(RXP,"L",LBL,0)) I PSOTXT'["(BAD ADDRESS)" Q
- .S PSOBADR=$$CHKRX^PSOBAI(RXP)
- .I '$G(PSOBADR) D SETLBL(LBL,"NO BAD ADDRESS INDICATOR AT RELEASE") Q
- .I $P(PSOBADR,"^",2) D SETLBL(LBL,"ACTIVE TEMPORARY ADDRESS AT RELEASE")
- Q
- ;
- SETLBL(LBL,PSOMSG) ;
- N PSOTXT
- S PSOTXT=$G(^PSRX(RXP,"L",LBL,0)),$P(PSOTXT,"^",3)=PSOMSG
- S LBL=LBL+1,^PSRX(RXP,"L",0)="^52.032DA^"_LBL_"^"_LBL
- S ^PSRX(RXP,"L",LBL,0)=PSOTXT
- Q
- PSODISPS ;BIR/SAB-CONTINUATION OF RELEASE FUNCTION ;05-Sep-2013 16:35;DU
- +1 ;;7.0;OUTPATIENT PHARMACY;**15,13,9,27,67,71,1006,156,118,148,247,200,1015,1016**;DEC 1997;Build 74
- +2 ;External reference ^PS(59.7 supported by DBIA 694
- +3 ;External reference to ^PSDRUG("AQ" supported by DBIA 3165
- +4 ;External reference ^XTMP("PSA" supported by DBIA 1036
- +5 ;External reference $$SERV^IBARX1 supported by DBIA 2245
- +6 ;External reference ^PSDRUG( supported by DBIA 221
- +7 ;Reference to ^DIC(19.2 supported by DBIA 1064
- +8 ;Modified - IHS/MSC/PLS - 10/22/07- Line QTY+6
- +9 ; IHS/MSC/MGH - 05/02/2013 - Line OERR+4
- QTY ; Refill Release
- +1 SET PSOCPN=$PIECE(^PSRX(RXP,0),"^",2)
- SET QDRUG=$PIECE(^PSRX(RXP,0),"^",6)
- KILL LBLP
- +2 FOR YY=0:0
- SET YY=$ORDER(^PSRX(RXP,XTYPE,YY))
- IF 'YY
- QUIT
- IF $PIECE($GET(^PSRX(RXP,XTYPE,YY,0)),"^")'<PSIN
- Begin DoDot:1
- +3 SET RXFD=$EXTRACT($PIECE(^PSRX(RXP,XTYPE,YY,0),"^"),1,7)
- SET SUPN=$ORDER(^PS(52.5,"B",RXP,0))
- IF SUPN
- IF $DATA(^PS(52.5,"C",RXFD,SUPN))
- IF $GET(^PS(52.5,SUPN,"P"))'=1
- IF $GET(XTYPE)
- SET ISUF=1
- QUIT
- +4 IF XTYPE=1
- IF ($DATA(^PSDRUG("AQ",QDRUG)))
- KILL CMOP
- DO RREL^PSOCMOPB(RXP,YY)
- KILL CMOP
- IF $GET(ISUF)
- QUIT
- +5 IF $PIECE(^PSRX(RXP,XTYPE,YY,0),"^",$SELECT($GET(XTYPE):18,1:19))]""!($PIECE(^(0),"^",16))
- KILL IFN
- QUIT
- +6 ;
- +7 FOR LBL=0:0
- SET LBL=$ORDER(^PSRX(RXP,"L",LBL))
- IF 'LBL
- QUIT
- IF $PIECE(^PSRX(RXP,"L",LBL,0),"^",2)=$SELECT('XTYPE:(99-YY),1:YY)
- SET LBLP=1
- +8 IF '$GET(LBLP)
- QUIT
- +9 DO CHKADDR(RXP)
- +10 ;
- +11 ; - Checking for OPEN/UNRESOLVED 3rd. Party Payer Rejects / NDC Editing
- +12 IF XTYPE
- IF $$MANREL^PSOBPSUT(RXP,YY,$GET(PSOPID))="^"
- KILL LBLP
- QUIT
- +13 ; IHS/MSC/PLS - 10/22/07 - suppress inventory mgmt if autofinished Rx.
- +14 ;S IFN=YY S:$G(^PSDRUG(QDRUG,660.1))]"" QTY=$P(^PSRX(RXP,XTYPE,YY,0),"^",4),^PSDRUG(QDRUG,660.1)=^PSDRUG(QDRUG,660.1)-QTY
- +15 SET IFN=YY
- IF $GET(^PSDRUG(QDRUG,660.1))]""
- SET QTY=$PIECE(^PSRX(RXP,XTYPE,YY,0),"^",4)
- SET ^PSDRUG(QDRUG,660.1)=^PSDRUG(QDRUG,660.1)-$SELECT($PIECE($GET(^PSRX(RXP,999999921)),U,3):0,1:QTY)
- +16 KILL DA,DR,DIE
- DO NOW^%DTC
- SET DIE="^PSRX("_RXP_","""_XTYPE_""","
- SET DA(1)=RXP
- +17 SET DA=YY
- SET DR=$SELECT(XTYPE:17,1:8)_"///"_%_";"_$SELECT(XTYPE:4,1:.05)_"////"_PSRH
- +18 SET PSODT=%
- DO ^DIE
- KILL DIE,DR,DA
- +19 ;
- +20 ; - Notifying IB through ECME of the Rx being released
- +21 IF XTYPE
- DO IBSEND^PSOBPSUT(RXP,YY)
- +22 ;
- +23 KILL PSODISPP
- IF $GET(XTYPE)="P"
- SET PSODISPP=1
- DO EN^PSOHLSN1(RXP,"ZD")
- KILL PSODISPP
- +24 IF XTYPE
- KILL ^PSRX("ACP",$PIECE($GET(^PSRX(RXP,0)),"^",2),$PIECE($GET(^PSRX(RXP,1,YY,0)),"^"),YY,RXP)
- +25 IF XTYPE
- IF $GET(IFN)
- IF '$GET(ISUF)
- SET PSOCPRX=$PIECE(^PSRX(RXP,0),"^")
- DO CP^PSOCP
- +26 ;if appropriate update ^XTMP("PSA", for Drug Acct.
- +27 IF $GET(PSODA)
- IF $GET(PSODA(1))
- IF '$DATA(^PSRX("AR",+PSODT,+RXP,YY))
- Begin DoDot:2
- +28 SET ^XTMP("PSA",+PSOSITE,+QDRUG,DT)=$GET(^XTMP("PSA",+PSOSITE,+QDRUG,DT))+$PIECE($GET(^PSRX(RXP,XTYPE,YY,0)),"^",4)
- End DoDot:2
- +29 ;initialize bingo board variables
- +30 IF $GET(IFN)
- IF $PIECE($GET(^PSRX(RXP,XTYPE,IFN,0)),"^",2)["W"
- SET BINGRPR="W"
- SET BNGPDV=$PIECE(^PSRX(RXP,XTYPE,IFN,0),"^",9)
- SET BINGNAM=$PIECE($GET(^PSRX(RXP,0)),"^",2)
- End DoDot:1
- KILL ISUF,LBLP
- +31 IF $GET(IFN)
- WRITE !?7,"Prescription Number "_$PIECE(^PSRX(RXP,0),"^")_$SELECT('$GET(XTYPE):" Partial Fill",1:" Refill(s)")_" Released"
- IF $GET(SPEED)
- GOTO XMIT
- +32 IF '$GET(IFN)
- WRITE !?7,"No "_$SELECT($GET(XTYPE):"Refill(s)",1:"Partial(s)")_" to be Released"
- XMIT ;build an send HL7 v2.4 messages to dispense system
- IF $GET(PSODISP)=2.4
- Begin DoDot:1
- +1 FOR I=0:0
- SET SUB=$ORDER(^PSRX(RXP,"A",I))
- IF 'I
- QUIT
- IF $PIECE(^PSRX(RXP,"A",I,0),"^",2)="N"
- Begin DoDot:2
- +2 DO NOW^%DTC
- SET PSODTM=%
- KILL ^UTILITY($JOB,"PSOHL")
- +3 SET IDGN=$PIECE(^PSRX(+RXP,0),"^",6)
- SET FP=$SELECT(XTYPE=1:"R",1:"P")
- +4 SET ^UTILITY($JOB,"PSOHL",1)=+RXP_"^"_IDGN_"^"_PSODTM_"^"_+$GET(PDUZ)_"^0^^PSO DISP^^^"_FP_"^"_IFN
- +5 SET ZTRTN="INIT^PSORELDT"
- SET ZTDESC="EXTERNAL INTERFACE FOR RELEASE DATE/TIME"
- SET ZTIO=""
- SET ZTDTH=$HOROLOG
- SET ZTSAVE("^UTILITY($J,""PSOHL"",")=""
- SET ZTSAVE("PSOSITE")=""
- SET ZTSAVE("RXP")=""
- DO ^%ZTLOAD
- KILL ^UTILITY($JOB,"PSOHL")
- End DoDot:2
- End DoDot:1
- +6 KILL IFN
- +7 QUIT
- STAT SET RX0=^PSRX(RXP,0)
- SET $PIECE(RX0,"^",15)=+^("STA")
- SET RX2=^PSRX(RXP,2)
- SET J=RXP
- DO ^PSOFUNC
- +1 WRITE !!?5,$CHAR(7),$CHAR(7),"Rx# "_$PIECE(^PSRX(RXP,0),"^")_" has a status of "_ST_" and is not eligible for",!?5,"release."_$SELECT('$DATA(^XUSEC("PSORPH",DUZ)):" Please check with a Pharmacist!",1:"")
- +2 KILL RX0,ST
- +3 QUIT
- OERR IF '$DATA(PSOPAR)
- DO ^PSOLSET
- IF '$DATA(PSOPAR)
- WRITE $CHAR(7),!!,?5,"Site Parameters must be defined to use the Release option!",!
- SET VALMBCK=""
- QUIT
- +1 SET VALMBCK="Q"
- SET Y=$GET(^PS(59,PSOSITE,"IB"))
- SET PSOIBSS=$$SERV^IBARX1(+Y)
- IF 'PSOIBSS
- DO IBSSR^PSOUTL
- IF 'PSOIBFL
- Begin DoDot:1
- +2 WRITE $CHAR(7),!!,"The IB SERVICE/SECTION defined in your site parameter file is not valid.",!,"You will not be able to release any medication until this is corrected!",!
- End DoDot:1
- SET VALMBCK=""
- GOTO EX
- +3 WRITE !!
- SET PSIN=+$PIECE($GET(^PS(59.7,1,49.99)),"^",2)
- SET RXP=$PIECE(PSOLST($PIECE(PSLST,",",ORD)),"^",2)
- +4 ;S DIC("S")="I $D(^XUSEC(""PSORPH"",+Y))",DIC("A")="Enter PHARMACIST: ",DIC="^VA(200,",DIC(0)="QEAM" D ^DIC G:"^"[X EX K DIC G:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))!(Y=-1) EX S PSRH=+Y
- +5 ;IHS/MSC/MGH Patch 1015 May 2,2013
- PHNAME SET DIC("S")="I $D(^XUSEC(""PSORPH"",+Y))"
- SET DIC("A")="Enter PHARMACIST: "
- SET DIC="^VA(200,"
- SET DIC(0)="QEAM"
- +1 DO ^DIC
- IF $LENGTH(X)=0
- GOTO PHNAME
- IF "^"[X
- GOTO EX
- KILL DIC
- IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))!(Y=-1)
- GOTO EX
- SET PSRH=+Y
- +2 ;END MOD
- OERR1 ;IHS/MSC/MGH 1016 Separated out for reissue code
- +1 ;check for Drug Acct background job K8 & K7.1
- +2 SET X="PSA IV ALL LOCATIONS"
- SET DIC(0)="MZ"
- SET DIC=19.2
- DO ^DIC
- IF Y=-1
- KILL DIC,X,Y
- GOTO DOIT
- +3 IF $PIECE($GET(Y(0)),U,2)>DT
- SET PSODA=1
- IF '$PIECE($GET(^XTMP("PSA",0)),U,2)
- SET $PIECE(^(0),U,2)=DT
- GOTO DOIT
- +4 SET X="PSA IV ALL LOCATIONS"
- SET DIC(0)="MZ"
- SET DIC=19
- DO ^DIC
- KILL DIC,X
- IF Y=-1
- GOTO DOIT
- +5 KILL DIQ,PSA
- SET DA=+Y
- SET DIC=19
- SET DIQ="PSA"
- SET DR=200
- SET DIQ(0)="IN"
- DO EN^DIQ1
- +6 IF '$DATA(PSA(19,DA,200,"I"))
- KILL DIC,DA,X,Y,DIQ
- GOTO DOIT
- +7 IF PSA(19,DA,200,"I")>DT
- SET PSODA=1
- IF '$PIECE($GET(^XTMP("PSA",0)),U,2)
- SET $PIECE(^(0),U,2)=DT
- +8 KILL PSA,DIC,DA,X,Y,DIQ
- +9 ;
- DOIT SET POERR=1
- DO FULL^VALM1
- DO BC1^PSODISP
- +1 IF $DATA(DISGROUP)
- IF $DATA(BINGNAM)
- IF ($DATA(BINGDIV)!$DATA(BNGPDV)!$DATA(BNGRDV))
- IF ($DATA(BINGRO)!$DATA(BINGRPR))
- NEW TM,TM1
- DO REL^PSOBING1
- KILL BINGNAM,BINGDIV,BINGRO,BINGRPR,BNGPDV,BNGRDV
- EX ;
- +1 KILL OUT,RX2,RXFD,RESK,ISUF,SUPN,%,DIC,IFN,J,DA,DR,DIE,X,X1,X2,Y,RXP,CX,PX,REC,DIR,YDT,REC,RDUZ,DIRUT,PSOCPN,PSOCPRX,PSOIBSS,PSOIBFL,PSOIBLP,PSOIBST,YY,QDRUG,QTY,TYPE,XTYPE,DUOUT,PSRH,XX,Y,PSIN,POERR,SUB
- +2 KILL DIR
- SET DIR("A",1)=" "
- SET DIR("A")="Press Return to Continue"
- SET DIR(0)="E"
- DO ^DIR
- KILL DIRUT,DUOUT,DTOUT,DIR
- SET VALMBCK="R"
- +3 SET PSORXED=1
- DO ^PSOBUILD
- DO ACT^PSOORNE2
- KILL PSORXED
- +4 QUIT
- +5 ;
- CHKADDR(RXP) ;
- +1 NEW PSOTXT,PSOBADR,PSOTEMP,LBL
- +2 SET LBL=$ORDER(^PSRX(RXP,"L",99999),-1)
- IF LBL>0
- Begin DoDot:1
- +3 SET PSOTXT=$GET(^PSRX(RXP,"L",LBL,0))
- IF PSOTXT'["(BAD ADDRESS)"
- QUIT
- +4 SET PSOBADR=$$CHKRX^PSOBAI(RXP)
- +5 IF '$GET(PSOBADR)
- DO SETLBL(LBL,"NO BAD ADDRESS INDICATOR AT RELEASE")
- QUIT
- +6 IF $PIECE(PSOBADR,"^",2)
- DO SETLBL(LBL,"ACTIVE TEMPORARY ADDRESS AT RELEASE")
- End DoDot:1
- +7 QUIT
- +8 ;
- SETLBL(LBL,PSOMSG) ;
- +1 NEW PSOTXT
- +2 SET PSOTXT=$GET(^PSRX(RXP,"L",LBL,0))
- SET $PIECE(PSOTXT,"^",3)=PSOMSG
- +3 SET LBL=LBL+1
- SET ^PSRX(RXP,"L",0)="^52.032DA^"_LBL_"^"_LBL
- +4 SET ^PSRX(RXP,"L",LBL,0)=PSOTXT
- +5 QUIT
