- PSGRET ;BIR/CML3-ENTER RETURNS ;17 SEP 97 / 1:41 PM
- ;;5.0; INPATIENT MEDICATIONS ;**31**;16 DEC 97
- ;
- ; Reference to ^PS(50.7 is supported by DBIA# 2180
- ; Reference to ^PS(51.2 is supported by DBIA #2178
- ; Reference to ^PS(55 is supported by DBIA# 2191
- ;
- N PSJNEW,PSGPTMP,PPAGE,PSGEFN S PSJNEW=1
- D ENCV^PSGSETU Q:$D(XQUIT) S (PSGONNV,PSGRETF)=1 K PSGPRP
- ;
- GP ;
- D ENDPT^PSGP G:PSGP'>0 DONE I '$O(^PS(55,PSGP,5,"AUS",+PSJPAD)) W $C(7),!,"(Patient has NO active or old orders.)" G GP
- D ENL^PSGOU G:"^N"[PSGOL GP S PSGPTMP=0,PPAGE=1 D ^PSGO G:'PSGON GP S PSGLMT=PSGON,(PSGONC,PSGONR)=0
- F W !!,"Select ORDER",$E("S",PSGON>1)," 1-",PSGON,": " R X:DTIME W:'$T $C(7) S:'$T X="^" Q:"^"[X D:X?1."?" H I X'?1."?" D ENCHK^PSGON W:'$D(X) $C(7)," ??" Q:$D(X)
- G:"^"[X GP F PSGRET=1:1:PSGODDD F PSGRET1=1:1 S PSGRET2=$P(PSGODDD(PSGRET),",",PSGRET1) Q:'PSGRET2 K DA S (PSGORD)=^TMP("PSJON",$J,PSGRET2) D R G:Y GP
- G GP
- ;
- DONE ;
- D ENKV^PSGSETU K ^TMP("PSJON",$J),DO,DRG,MR,OD,PSGLMT,PSGODDD,PSGOL,PSGON,PSGONC,PSGONR,PSGONV,PSGONNV,PSGORD,PSGRET,PSGRET1,PSGRET2,PSGRETF,SCH,Y1,Z Q
- ;
- R ;
- S MR=$P($G(^PS(55,PSGP,5,+PSGORD,0)),"^",3),Y=$G(^(.2)),SCH=$P($G(^(2)),"^"),DO=$P(Y,"^",2),DRG=$P(Y,"^"),DRG=$S(DRG'=+DRG:"NOT FOUND",'$D(^PS(50.7,DRG,0)):DRG,$P(^(0),"^")]"":$P(^(0),"^"),1:DRG_";PS(50.7,")
- S:MR]"" MR=$S(MR'=MR:MR,'$D(^PS(51.2,MR,0)):MR,$P(^(0),"^",3)]"":$P(^(0),"^",3),$P(^(0),"^")]"":$P(^(0),"^"),1:MR_";PS(51.2,") W !!,"----------------------------------------",!,DRG,!,"Give: ",DO," ",MR," ",SCH
- I '$O(^PS(55,PSGP,5,+PSGORD,1,0)) D Q
- .W !!,"No Dispense drugs have been entered for this order. At least one Dispense drugs",!,"must be associated with an order before dispensing information may be entered.",!!
- .N DIR S DIR(0)="E" D ^DIR S Y=$S(Y:0,1:1)
- S Y=$O(^PS(55,PSGP,5,+PSGORD,1,0)) I '$O(^(Y)),$D(^(Y,0)) S DRG=$P(^(0),"^"),UD=$P(^(0),"^",2),DRG=$$ENDDN^PSGMI(DRG)
- I W !!,"Dispense drug: ",DRG," (U/D: ",$S('UD:1,1:UD),")"
- E K DA,DIC S DA(1)=PSGP,DA(2)=+PSGORD,DA=+PSGORD,DIC="^PS(55,"_PSGP_",5,"_+PSGORD_",1,",DIC(0)="AEQM" W ! D ^DIC K DIC Q:Y'>0
- K DA,DR S DA=+Y,DA(2)=PSGP,DA(1)=+PSGORD,DIE="^PS(55,"_PSGP_",5,"_+PSGORD_",1,",DR=.08 S:$P($G(^PS(55,PSGP,5,+PSGORD,1,DA,0)),"^",8) $P(^(0),"^",8)="" W ! D ^DIE S Y=$D(DUOUT)!$D(DTOUT)
- Q
- ;
- H ;
- W !!?2,"Select the orders (by number) for which you want to enter returns." D:X'="?" H2^PSGON Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGRET 2405 printed Feb 18, 2025@23:29:28 Page 2
- PSGRET ;BIR/CML3-ENTER RETURNS ;17 SEP 97 / 1:41 PM
- +1 ;;5.0; INPATIENT MEDICATIONS ;**31**;16 DEC 97
- +2 ;
- +3 ; Reference to ^PS(50.7 is supported by DBIA# 2180
- +4 ; Reference to ^PS(51.2 is supported by DBIA #2178
- +5 ; Reference to ^PS(55 is supported by DBIA# 2191
- +6 ;
- +7 NEW PSJNEW,PSGPTMP,PPAGE,PSGEFN
- SET PSJNEW=1
- +8 DO ENCV^PSGSETU
- if $DATA(XQUIT)
- QUIT
- SET (PSGONNV,PSGRETF)=1
- KILL PSGPRP
- +9 ;
- GP ;
- +1 DO ENDPT^PSGP
- if PSGP'>0
- GOTO DONE
- IF '$ORDER(^PS(55,PSGP,5,"AUS",+PSJPAD))
- WRITE $CHAR(7),!,"(Patient has NO active or old orders.)"
- GOTO GP
- +2 DO ENL^PSGOU
- if "^N"[PSGOL
- GOTO GP
- SET PSGPTMP=0
- SET PPAGE=1
- DO ^PSGO
- if 'PSGON
- GOTO GP
- SET PSGLMT=PSGON
- SET (PSGONC,PSGONR)=0
- +3 FOR
- WRITE !!,"Select ORDER",$EXTRACT("S",PSGON>1)," 1-",PSGON,": "
- READ X:DTIME
- if '$TEST
- WRITE $CHAR(7)
- if '$TEST
- SET X="^"
- if "^"[X
- QUIT
- if X?1."?"
- DO H
- IF X'?1."?"
- DO ENCHK^PSGON
- if '$DATA(X)
- WRITE $CHAR(7)," ??"
- if $DATA(X)
- QUIT
- +4 if "^"[X
- GOTO GP
- FOR PSGRET=1:1:PSGODDD
- FOR PSGRET1=1:1
- SET PSGRET2=$PIECE(PSGODDD(PSGRET),",",PSGRET1)
- if 'PSGRET2
- QUIT
- KILL DA
- SET (PSGORD)=^TMP("PSJON",$JOB,PSGRET2)
- DO R
- if Y
- GOTO GP
- +5 GOTO GP
- +6 ;
- DONE ;
- +1 DO ENKV^PSGSETU
- KILL ^TMP("PSJON",$JOB),DO,DRG,MR,OD,PSGLMT,PSGODDD,PSGOL,PSGON,PSGONC,PSGONR,PSGONV,PSGONNV,PSGORD,PSGRET,PSGRET1,PSGRET2,PSGRETF,SCH,Y1,Z
- QUIT
- +2 ;
- R ;
- +1 SET MR=$PIECE($GET(^PS(55,PSGP,5,+PSGORD,0)),"^",3)
- SET Y=$GET(^(.2))
- SET SCH=$PIECE($GET(^(2)),"^")
- SET DO=$PIECE(Y,"^",2)
- SET DRG=$PIECE(Y,"^")
- SET DRG=$SELECT(DRG'=+DRG:"NOT FOUND",'$DATA(^PS(50.7,DRG,0)):DRG,$PIECE(^(0),"^")]"":$PIECE(^(0),"^"),1:DRG_";PS(50.7,")
- +2 if MR]""
- SET MR=$SELECT(MR'=MR:MR,'$DATA(^PS(51.2,MR,0)):MR,$PIECE(^(0),"^",3)]"":$PIECE(^(0),"^",3),$PIECE(^(0),"^")]"":$PIECE(^(0),"^"),1:MR_";PS(51.2,")
- WRITE !!,"----------------------------------------",!,DRG,!,"Give: ",DO," ",MR," ",SCH
- +3 IF '$ORDER(^PS(55,PSGP,5,+PSGORD,1,0))
- Begin DoDot:1
- +4 WRITE !!,"No Dispense drugs have been entered for this order. At least one Dispense drugs",!,"must be associated with an order before dispensing information may be entered.",!!
- +5 NEW DIR
- SET DIR(0)="E"
- DO ^DIR
- SET Y=$SELECT(Y:0,1:1)
- End DoDot:1
- QUIT
- +6 SET Y=$ORDER(^PS(55,PSGP,5,+PSGORD,1,0))
- IF '$ORDER(^(Y))
- IF $DATA(^(Y,0))
- SET DRG=$PIECE(^(0),"^")
- SET UD=$PIECE(^(0),"^",2)
- SET DRG=$$ENDDN^PSGMI(DRG)
- +7 IF $TEST
- WRITE !!,"Dispense drug: ",DRG," (U/D: ",$SELECT('UD:1,1:UD),")"
- +8 IF '$TEST
- KILL DA,DIC
- SET DA(1)=PSGP
- SET DA(2)=+PSGORD
- SET DA=+PSGORD
- SET DIC="^PS(55,"_PSGP_",5,"_+PSGORD_",1,"
- SET DIC(0)="AEQM"
- WRITE !
- DO ^DIC
- KILL DIC
- if Y'>0
- QUIT
- +9 KILL DA,DR
- SET DA=+Y
- SET DA(2)=PSGP
- SET DA(1)=+PSGORD
- SET DIE="^PS(55,"_PSGP_",5,"_+PSGORD_",1,"
- SET DR=.08
- if $PIECE($GET(^PS(55,PSGP,5,+PSGORD,1,DA,0)),"^",8)
- SET $PIECE(^(0),"^",8)=""
- WRITE !
- DO ^DIE
- SET Y=$DATA(DUOUT)!$DATA(DTOUT)
- +10 QUIT
- +11 ;
- H ;
- +1 WRITE !!?2,"Select the orders (by number) for which you want to enter returns."
- if X'="?"
- DO H2^PSGON
- QUIT
