PSODACT ;BHAM ISC/JrR - CREATE DUE ANSWER SHEET FROM ACTION PROFILE ; 11/18/92 18:58
;;7.0;OUTPATIENT PHARMACY;**2,326**;DEC 1997;Build 11
Q
ENSAVE ;Enter here from PSOSD0 to store info about each DUE RX
;as Action Profile is printing. Needs RXNODE=NODE '0' OF RXN,RXN
S PSOQDRG=$P(RXNODE,"^",6),PSOQDFN=$P(RXNODE,"^",2)
I $D(^PS(50.073,"AD",PSOQDRG)),('$P(RXNODE,"^",15)!($P(RXNODE,"^",15)=5)) F PSOQ=0:0 S PSOQ=$O(^PS(50.073,"AD",PSOQDRG,PSOQ)) Q:'PSOQ D
.I $P(^PS(50.073,PSOQ,0),"^",2),$P(^(0),"^",3) F DIV=0:0 S DIV=$O(^PS(50.073,PSOQ,3,DIV)) Q:'DIV I $P(^PS(50.073,PSOQ,3,DIV,0),"^")=$G(PSOSITE) D STORE
K PSOQ,PSOQDRG,PSOQDFN,DIV
QUIT
;return to ^PSOSD0
;
STORE S ^TMP("PSOD",$J,RXN,PSOQDRG,PSOQ,5)=$P(RXNODE,"^",4)
S ^TMP("PSOD",$J,RXN,PSOQDRG,PSOQ,8)=PSOQDFN
Q
;
ENSTUFF ;Enter here from PSOSD Action Profile
;Print an Answer sheet for DUE RXs stored at ENSAVE above
NEW I,RXN
Q:'$D(^TMP("PSOD",$J))
F RXN=0:0 S RXN=$O(^TMP("PSOD",$J,RXN)) Q:'RXN F PSOQDRG=0:0 S PSOQDRG=$O(^TMP("PSOD",$J,RXN,PSOQDRG)) Q:'PSOQDRG F PSOQ=0:0 S PSOQ=$O(^TMP("PSOD",$J,RXN,PSOQDRG,PSOQ)) Q:'PSOQ D PRINT
K ^TMP("PSOD",$J) W:'$D(PSONOPG) @IOF
K PSOQDRG,PSOQ,PSA,PIECE,FLAG,I,PSOQPHYS,DFN,SSN,PSIGN,PSOQL
K PSOQDFN,PSOQM,PSOQSSN,PSQNUM,PSOQN,PSOQNUM,PSQ,PSTXT,PSWRAP,PSMARG
QUIT
;return to ^PSOSD
;
SET ;This code is not being executed at this time.
D NEW S PSA=+Y
S $P(^PS(50.0731,PSA,0),"^",2,4)=PSOQ_"^"_PSOQDRG_"^"_RXN
F PIECE=5,8 S $P(^PS(50.0731,PSA,0),"^",PIECE)=^TMP("PSOD",$J,RXN,PSOQDRG,PSOQ,PIECE)
MOVE S FLAG=0
F I=0:0 S I=$O(^PS(50.073,PSOQ,2,I)) Q:'I S:$D(^PS(50.0732,$P(^(I,0),"^",2),0)) ^PS(50.0731,PSA,1,I,0)=^PS(50.073,PSOQ,2,I,0),$P(^PS(50.0732,$P(^(0),"^",2),0),"^",7)=1,FLAG=1
S:FLAG $P(^PS(50.073,PSOQ,0),"^",4)=1,^PS(50.0731,PSA,1,0)="^50.07311IA^"_$P(^PS(50.073,PSOQ,2,0),"^",3,4)
S DIK="^PS(50.0731,",DA=PSA D IX^DIK K DIK,DA
Q
;
NEW ;laygo into the DUE Answer file
L +^PS(50.0731,0):20
S X=$P(^PS(50.0731,0),"^",3)
LOOP S X=X+1 G:$D(^PS(50.0731,X)) LOOP L
K DIC,DD,DO S DIC="^PS(50.0731,",DIC(0)="XL",DIC("DR")="6///NOW",DLAYGO=50.0731,DINUM=X D FILE^DICN
K DIC,DLAYGO,DINUM
L -^PS(50.0731,0)
Q:$P(Y,"^",3)
G NEW
;
PRINT ;prints DUE Questionnaire
W @IOF,!!,@$S($G(PSORM)=0:"?25",1:"?52"),"***** Due Answer Sheet *****"
W !!,"SEQ. Number: _______________",?($X+3),"Questionnaire: "_$P(^PS(50.073,PSOQ,0),"^"),@$S($G(PSORM)=0:"!",1:"?$X+3"),"Drug: "_$P(^PSDRUG(PSOQDRG,0),"^"),@$S($G(PSORM)=0:"?45",1:"?109"),"Rx #: "_$P(^PSRX(RXN,0),"^")
S PSOQPHYS=$P($G(^VA(200,+$P(^PSRX(RXN,0),"^",4),0)),"^")
W !!,"Rx Provider: ",$E(PSOQPHYS,1,20)
S PSOQDFN=^TMP("PSOD",$J,RXN,PSOQDRG,PSOQ,8)
W ?($X+3),"Patient: ",$P(^DPT(PSOQDFN,0),"^"),@$S($G(PSORM)=0:"!",1:"?$X+3"),?($X+3),"Section: ______________"
W @$S($G(PSORM)=0:"?$X+3",1:"?109"),"Date: "
S Y=DT D DT^DIQ
QOUT ;Enter here from ^PSODUE to print questions for Questionaire
K PSOQL S $P(PSOQL,"-",$S($G(PSORM)=0:80,1:IOM))="" W !,PSOQL
I $O(^PS(50.073,PSOQ,"N",0)) D NARATV,^DIWW K DIWF,DIWL,DIWR
S PSIGN=0
I $O(^PS(50.073,PSOQ,2,0)) F PSOQN=0:0 S PSOQN=$O(^PS(50.073,PSOQ,2,PSOQN)) Q:'PSOQN S PSIGN=1,PSOQM=^(PSOQN,0) D:$P(PSOQM,"^",2)
.S PSQNUM=+PSOQM,PSQ=$P(^PS(50.0732,$P(PSOQM,"^",2),0),"^") D WRAP^PSODEDT W !?($L(PSQNUM)+2),"Answer: ",! I $Y>(IOSL-7) W @IOF
W:PSIGN ?(IOM-40),"Signature: __________________________",!
Q
NARATV K ^UTILITY($J,"W") S DIWL=4,DIWR=$S($G(PSORM)=0:80,1:IOM),DIWF="WN" F PSOQN=0:0 S PSOQN=$O(^PS(50.073,PSOQ,"N",PSOQN)) Q:'PSOQN S X=^(PSOQN,0) D ^DIWP
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSODACT 3572 printed Nov 22, 2024@17:36:22 Page 2
PSODACT ;BHAM ISC/JrR - CREATE DUE ANSWER SHEET FROM ACTION PROFILE ; 11/18/92 18:58
+1 ;;7.0;OUTPATIENT PHARMACY;**2,326**;DEC 1997;Build 11
+2 QUIT
ENSAVE ;Enter here from PSOSD0 to store info about each DUE RX
+1 ;as Action Profile is printing. Needs RXNODE=NODE '0' OF RXN,RXN
+2 SET PSOQDRG=$PIECE(RXNODE,"^",6)
SET PSOQDFN=$PIECE(RXNODE,"^",2)
+3 IF $DATA(^PS(50.073,"AD",PSOQDRG))
IF ('$PIECE(RXNODE,"^",15)!($PIECE(RXNODE,"^",15)=5))
FOR PSOQ=0:0
SET PSOQ=$ORDER(^PS(50.073,"AD",PSOQDRG,PSOQ))
if 'PSOQ
QUIT
Begin DoDot:1
+4 IF $PIECE(^PS(50.073,PSOQ,0),"^",2)
IF $PIECE(^(0),"^",3)
FOR DIV=0:0
SET DIV=$ORDER(^PS(50.073,PSOQ,3,DIV))
if 'DIV
QUIT
IF $PIECE(^PS(50.073,PSOQ,3,DIV,0),"^")=$GET(PSOSITE)
DO STORE
End DoDot:1
+5 KILL PSOQ,PSOQDRG,PSOQDFN,DIV
+6 QUIT
+7 ;return to ^PSOSD0
+8 ;
STORE SET ^TMP("PSOD",$JOB,RXN,PSOQDRG,PSOQ,5)=$PIECE(RXNODE,"^",4)
+1 SET ^TMP("PSOD",$JOB,RXN,PSOQDRG,PSOQ,8)=PSOQDFN
+2 QUIT
+3 ;
ENSTUFF ;Enter here from PSOSD Action Profile
+1 ;Print an Answer sheet for DUE RXs stored at ENSAVE above
+2 NEW I,RXN
+3 if '$DATA(^TMP("PSOD",$JOB))
QUIT
+4 FOR RXN=0:0
SET RXN=$ORDER(^TMP("PSOD",$JOB,RXN))
if 'RXN
QUIT
FOR PSOQDRG=0:0
SET PSOQDRG=$ORDER(^TMP("PSOD",$JOB,RXN,PSOQDRG))
if 'PSOQDRG
QUIT
FOR PSOQ=0:0
SET PSOQ=$ORDER(^TMP("PSOD",$JOB,RXN,PSOQDRG,PSOQ))
if 'PSOQ
QUIT
DO PRINT
+5 KILL ^TMP("PSOD",$JOB)
if '$DATA(PSONOPG)
WRITE @IOF
+6 KILL PSOQDRG,PSOQ,PSA,PIECE,FLAG,I,PSOQPHYS,DFN,SSN,PSIGN,PSOQL
+7 KILL PSOQDFN,PSOQM,PSOQSSN,PSQNUM,PSOQN,PSOQNUM,PSQ,PSTXT,PSWRAP,PSMARG
+8 QUIT
+9 ;return to ^PSOSD
+10 ;
SET ;This code is not being executed at this time.
+1 DO NEW
SET PSA=+Y
+2 SET $PIECE(^PS(50.0731,PSA,0),"^",2,4)=PSOQ_"^"_PSOQDRG_"^"_RXN
+3 FOR PIECE=5,8
SET $PIECE(^PS(50.0731,PSA,0),"^",PIECE)=^TMP("PSOD",$JOB,RXN,PSOQDRG,PSOQ,PIECE)
MOVE SET FLAG=0
+1 FOR I=0:0
SET I=$ORDER(^PS(50.073,PSOQ,2,I))
if 'I
QUIT
if $DATA(^PS(50.0732,$PIECE(^(I,0),"^",2),0))
SET ^PS(50.0731,PSA,1,I,0)=^PS(50.073,PSOQ,2,I,0)
SET $PIECE(^PS(50.0732,$PIECE(^(0),"^",2),0),"^",7)=1
SET FLAG=1
+2 if FLAG
SET $PIECE(^PS(50.073,PSOQ,0),"^",4)=1
SET ^PS(50.0731,PSA,1,0)="^50.07311IA^"_$PIECE(^PS(50.073,PSOQ,2,0),"^",3,4)
+3 SET DIK="^PS(50.0731,"
SET DA=PSA
DO IX^DIK
KILL DIK,DA
+4 QUIT
+5 ;
NEW ;laygo into the DUE Answer file
+1 LOCK +^PS(50.0731,0):20
+2 SET X=$PIECE(^PS(50.0731,0),"^",3)
LOOP SET X=X+1
if $DATA(^PS(50.0731,X))
GOTO LOOP
LOCK
+1 KILL DIC,DD,DO
SET DIC="^PS(50.0731,"
SET DIC(0)="XL"
SET DIC("DR")="6///NOW"
SET DLAYGO=50.0731
SET DINUM=X
DO FILE^DICN
+2 KILL DIC,DLAYGO,DINUM
+3 LOCK -^PS(50.0731,0)
+4 if $PIECE(Y,"^",3)
QUIT
+5 GOTO NEW
+6 ;
PRINT ;prints DUE Questionnaire
+1 WRITE @IOF,!!,@$SELECT($GET(PSORM)=0:"?25",1:"?52"),"***** Due Answer Sheet *****"
+2 WRITE !!,"SEQ. Number: _______________",?($X+3),"Questionnaire: "_$PIECE(^PS(50.073,PSOQ,0),"^"),@$SELECT($GET(PSORM)=0:"!",1:"?$X+3"),"Drug: "_$PIECE(^PSDRUG(PSOQDRG,0),"^"),@$SELECT($GET(PSORM)=0:"?45",1:"?109"),"Rx #: "_$PIECE(^PSRX(RXN,0),"
^")
+3 SET PSOQPHYS=$PIECE($GET(^VA(200,+$PIECE(^PSRX(RXN,0),"^",4),0)),"^")
+4 WRITE !!,"Rx Provider: ",$EXTRACT(PSOQPHYS,1,20)
+5 SET PSOQDFN=^TMP("PSOD",$JOB,RXN,PSOQDRG,PSOQ,8)
+6 WRITE ?($X+3),"Patient: ",$PIECE(^DPT(PSOQDFN,0),"^"),@$SELECT($GET(PSORM)=0:"!",1:"?$X+3"),?($X+3),"Section: ______________"
+7 WRITE @$SELECT($GET(PSORM)=0:"?$X+3",1:"?109"),"Date: "
+8 SET Y=DT
DO DT^DIQ
QOUT ;Enter here from ^PSODUE to print questions for Questionaire
+1 KILL PSOQL
SET $PIECE(PSOQL,"-",$SELECT($GET(PSORM)=0:80,1:IOM))=""
WRITE !,PSOQL
+2 IF $ORDER(^PS(50.073,PSOQ,"N",0))
DO NARATV
DO ^DIWW
KILL DIWF,DIWL,DIWR
+3 SET PSIGN=0
+4 IF $ORDER(^PS(50.073,PSOQ,2,0))
FOR PSOQN=0:0
SET PSOQN=$ORDER(^PS(50.073,PSOQ,2,PSOQN))
if 'PSOQN
QUIT
SET PSIGN=1
SET PSOQM=^(PSOQN,0)
if $PIECE(PSOQM,"^",2)
Begin DoDot:1
+5 SET PSQNUM=+PSOQM
SET PSQ=$PIECE(^PS(50.0732,$PIECE(PSOQM,"^",2),0),"^")
DO WRAP^PSODEDT
WRITE !?($LENGTH(PSQNUM)+2),"Answer: ",!
IF $Y>(IOSL-7)
WRITE @IOF
End DoDot:1
+6 if PSIGN
WRITE ?(IOM-40),"Signature: __________________________",!
+7 QUIT
NARATV KILL ^UTILITY($JOB,"W")
SET DIWL=4
SET DIWR=$SELECT($GET(PSORM)=0:80,1:IOM)
SET DIWF="WN"
FOR PSOQN=0:0
SET PSOQN=$ORDER(^PS(50.073,PSOQ,"N",PSOQN))
if 'PSOQN
QUIT
SET X=^(PSOQN,0)
DO ^DIWP
+1 QUIT
