- 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
- 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
