GMRGRUT3 ;HIRMFO/RM-GMRG ROUTINE UTILITIES ;9/11/95
;;3.0;Text Generator;;Jan 24, 1996
EN1 ;SELECT PATIENT CARE PLAN
; INPUT: GMRGRT=PRIME DOC IEN^PD TEXT
; DFN=PATIENT IEN
; (optional) GMRGXPRT=$S(1:ALL PLANS E/E OR NOT,0:ONLY ACTIVE)
; _"^"_$S(1:CAN LAYGO NEW PLANS,0:LAYGO NOT ALLOWED)_"^"_
; $S(1:ENTRY IN ERROR OF PLANS ALLOWED,0:E/E NOT ALLOWED)
; DEFAULT VALUE IS "0^1^0"
; OUTPUT: GMRGPDA=ENTRY IN 124.3
; GMRGOUT=$S(1:ABNORMAL EXIT,0:NORMAL EXIT)
Q:'$D(GMRGRT)!'$D(DFN) S GMRGOUT=0,GMRGPDA=-1 S:'$D(GMRGXPRT)#2 GMRGXPRT="0^1^0"
S (GMRGZ(0),GMRGZ)=1 F GMRGX=0:0 S GMRGX=$O(^GMR(124.3,"AA",DFN,+GMRGRT,GMRGX)) Q:GMRGX'>0 F GMRGY=0:0 S GMRGY=$O(^GMR(124.3,"AA",DFN,+GMRGRT,GMRGX,GMRGY)) Q:GMRGY'>0 D STRY
S GMRGXSEL=GMRGZ-1,GMRGXERR=GMRGZ(0)-1,GMRGXREF="GMRGXSEL"
G:GMRGXSEL>0 CPCH
YNNP ; IF NO 124.3 ENTRIES EXIST
W !,"There is no previous "_$P(GMRGRT,"^",2)_" for this patient."
G:'$P(GMRGXPRT,"^",2) Q1:GMRGXERR'>0!'$P(GMRGXPRT,"^"),CPCH
W !,"Would you like to add one" S %=1 D YN^DICN S:%=-1 GMRGOUT=1 I '% W !?3,$C(7),"Answer Yes or No." G YNNP
D:%=1 NEWCP
G Q1
;
CPCH ; CHOOSE FROM EXISTING 124.3 ENTRIES
I @GMRGXREF>0 W !!,"The following is a list of previous "_$P(GMRGRT,"^",2)_$E("s",("Ss"'[$E($P(GMRGRT,"^",2),$L($P(GMRGRT,"^",2))))),! W:GMRGXREF="GMRGXERR" "that have been entered in error",!
F GMRGZ=0:0 S GMRGZ=$O(@(GMRGXREF_"("_GMRGZ_")")) Q:GMRGZ'>0 S GMRGX=((GMRGZ#10)=1&(GMRGZ'=1)),X="" W:GMRGX !,"'^' TO STOP: " R:GMRGX X:DTIME S:GMRGX&(X="^^"!'$T) GMRGOUT=1 Q:(X="^"!GMRGOUT)&GMRGX D PRTC
I GMRGOUT Q:GMRGXREF="GMRGXERR" G Q1
W !!,"Enter Selection: "
R GMRGX:DTIME S:'$T GMRGX="^^"
I "^^"[GMRGX S:GMRGX="^^"!(GMRGX="^") GMRGOUT=1 Q:GMRGXREF="GMRGXERR" G Q1
S:GMRGX?1L GMRGX=$C($A(GMRGX)-32) S:GMRGXREF="GMRGXERR"&(GMRGX'?1N.N)!(GMRGX["@"&'$P(GMRGXPRT,"^",3)) GMRGX="??"
I '(GMRGX?1N.N."@"!(GMRGX="N"&$P(GMRGXPRT,"^",2))!(GMRGX="E"&$P(GMRGXPRT,"^"))) W !?3,$C(7),"ENTER THE NUMBER OF THE SELECTION TO BE CHOSEN" W:$P(GMRGXPRT,"^",3) ",",!?3,"OR THE NUMBER FOLLOWED BY AN '@' TO DELETE A SELECTION"
I W:GMRGXREF'="GMRGXERR"&$P(GMRGXPRT,"^",2) ",",!?3,"OR THE LETTER 'N' TO ADD A NEW ",$P(GMRGRT,"^",2) W:GMRGXREF'="GMRGXERR"&$P(GMRGXPRT,"^") ",",!?3,"OR TYPE AN 'E' TO LIST THE PLANS ENTERED IN ERROR" W "." G CPCH
I GMRGX?1N.N."@",(+GMRGX<1!(+GMRGX>@GMRGXREF)) W !?3,$C(7),"Select a number in the range 1"_$S(@GMRGXREF>1:"-"_@GMRGXREF,1:"") G CPCH
I "Ee"[GMRGX S GMRGXREF="GMRGXERR" D:@GMRGXREF>0 CPCH W:@GMRGXREF'>0 !?5,$C(7),"THERE ARE NO RECORDS ENTERED IN ERROR, TRY AGAIN." S GMRGXREF="GMRGXSEL" G Q1:GMRGPDA>0!GMRGOUT,CPCH
I "Nn"[GMRGX D NEWCP G Q1
I GMRGX["@" D DELPL G Q1:GMRGOUT,CPCH:+GMRGX<0
S GMRGPDA=$P(@(GMRGXREF_"("_+GMRGX_")"),"^",2)_$S(GMRGX'["@":"",1:"^@") Q:GMRGXREF="GMRGXERR"
Q1 K %,DA,DIC,DIE,DR,GMRGXERR,GMRGXPRT,GMRGXREF,GMRGXSEL,GMRGX,GMRGY,GMRGZ,X,Y Q
PRTC ; PRINT AN ENTRY FROM FILE 124.3
W !,$J(GMRGZ,3,0),". " S Y=$P(@(GMRGXREF_"("_GMRGZ_")"),"^") D DT^DIQ S GMRGY=$S($D(^GMR(124.3,$P(@(GMRGXREF_"("_GMRGZ_")"),"^",2),0)):$P(^(0),"^",5),1:""),GMRGY=$S(GMRGY="":"",$D(^VA(200,GMRGY,0)):$P(^(0),"^"),1:"") W ?30,GMRGY
Q
NEWCP ; ADD A NEW 124.3 ENTRY
D NOW^%DTC W !,"Let me create a new record..." S GMRGX=%,X=+GMRGRT,DIC="^GMR(124.3,",DIC(0)="Q",DIC("DR")=".02///^S X=""`""_DFN;.03///^S X=GMRGX" K DD D FILE^DICN S GMRGPDA=+Y
Q
DELPL ; ENTER A 124.3 ENTRY IN ERROR
W !,?3,$C(7),"ARE YOU SURE YOU WANT TO ENTER THIS ",$P(GMRGRT,"^",2)," IN ERROR" S %=0 D YN^DICN I '% W !?5,$C(7),"Answer Yes to enter this selection in error, else answer No." G DELPL
S:%=-1 GMRGOUT=1 S:%=2 GMRGX=-1 Q:%'=1
S DA=$P(GMRGXSEL(+GMRGX),"^",2),DIE="^GMR(124.3,",DR="5///1" D ^DIE W "."
Q
STRY ; SET UP GMRGXSEL( AND GMRGXERR( OF 124.3 ENTRIES TO BE SELECTED
S X=$S($D(^GMR(124.3,+GMRGY,5)):+^(5),1:0) Q:X&'$P(GMRGXPRT,"^")
I 'X S GMRGXSEL(GMRGZ)=(9999999-GMRGX)_"^"_GMRGY,GMRGZ=GMRGZ+1
I X S GMRGXERR(GMRGZ(0))=(9999999-GMRGX)_"^"_GMRGY,GMRGZ(0)=GMRGZ(0)+1
Q
EN4 ; PRUNE A SUBTREE FROM SOME PATIENT DATA SET
; GMRGPDA=ENTRY IN FILE 124.3
; GMRGTERM=ENTRY IN FILE 124.2 WHICH IS THE ROOT OF THE SUBTREE
G Q4:'$D(GMRGPDA)!'$D(GMRGTERM)
S X=GMRGTERM N GMRGTERM,GMRGOUT,GMRGPRC,GMRGRT,GMRGX,GMRGZZ S GMRGTERM=X
S GMRGTERM(0)=$G(^GMRD(124.2,+GMRGTERM,0)),GMRGX=$G(^GMR(124.3,+GMRGPDA,0)) G Q4:GMRGTERM(0)=""!(GMRGX="")
S GMRGRT=+GMRGX_"^"_$P($G(^GMRD(124.2,+GMRGX,0)),"^"),GMRGOUT=0 D PTDATA
I +GMRGTERM'=+GMRGRT D DELETE^GMRGED6 G Q4
F GMRGZZ=0:0 S GMRGZZ=$O(^GMRD(124.2,+GMRGRT,1,GMRGZZ)) Q:GMRGZZ'>0 S GMRGTERM=+$G(^GMRD(124.2,+GMRGRT,1,GMRGZZ,0)),GMRGTERM(0)=$G(^GMRD(124.2,+GMRGTERM,0)) I +GMRGTERM D PTDATA,DELETE^GMRGED6
Q4 ;
Q
PTDATA ;
S GMRGX=$O(^GMR(124.3,GMRGPDA,1,"B",GMRGTERM,0)),GMRGX(0)=$P($G(^GMR(124.3,GMRGPDA,1,+GMRGX,0)),"^",2),GMRGPRC=GMRGTERM_"^@^11",GMRGPRC(0)=$P(GMRGTERM(0),"^")_"^"_GMRGX_"^"_GMRGX(0)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRGRUT3 4964 printed Jan 18, 2025@02:56:48 Page 2
GMRGRUT3 ;HIRMFO/RM-GMRG ROUTINE UTILITIES ;9/11/95
+1 ;;3.0;Text Generator;;Jan 24, 1996
EN1 ;SELECT PATIENT CARE PLAN
+1 ; INPUT: GMRGRT=PRIME DOC IEN^PD TEXT
+2 ; DFN=PATIENT IEN
+3 ; (optional) GMRGXPRT=$S(1:ALL PLANS E/E OR NOT,0:ONLY ACTIVE)
+4 ; _"^"_$S(1:CAN LAYGO NEW PLANS,0:LAYGO NOT ALLOWED)_"^"_
+5 ; $S(1:ENTRY IN ERROR OF PLANS ALLOWED,0:E/E NOT ALLOWED)
+6 ; DEFAULT VALUE IS "0^1^0"
+7 ; OUTPUT: GMRGPDA=ENTRY IN 124.3
+8 ; GMRGOUT=$S(1:ABNORMAL EXIT,0:NORMAL EXIT)
+9 if '$DATA(GMRGRT)!'$DATA(DFN)
QUIT
SET GMRGOUT=0
SET GMRGPDA=-1
if '$DATA(GMRGXPRT)#2
SET GMRGXPRT="0^1^0"
+10 SET (GMRGZ(0),GMRGZ)=1
FOR GMRGX=0:0
SET GMRGX=$ORDER(^GMR(124.3,"AA",DFN,+GMRGRT,GMRGX))
if GMRGX'>0
QUIT
FOR GMRGY=0:0
SET GMRGY=$ORDER(^GMR(124.3,"AA",DFN,+GMRGRT,GMRGX,GMRGY))
if GMRGY'>0
QUIT
DO STRY
+11 SET GMRGXSEL=GMRGZ-1
SET GMRGXERR=GMRGZ(0)-1
SET GMRGXREF="GMRGXSEL"
+12 if GMRGXSEL>0
GOTO CPCH
YNNP ; IF NO 124.3 ENTRIES EXIST
+1 WRITE !,"There is no previous "_$PIECE(GMRGRT,"^",2)_" for this patient."
+2 if '$PIECE(GMRGXPRT,"^",2)
if GMRGXERR'>0!'$PIECE(GMRGXPRT,"^")
GOTO Q1
GOTO CPCH
+3 WRITE !,"Would you like to add one"
SET %=1
DO YN^DICN
if %=-1
SET GMRGOUT=1
IF '%
WRITE !?3,$CHAR(7),"Answer Yes or No."
GOTO YNNP
+4 if %=1
DO NEWCP
+5 GOTO Q1
+6 ;
CPCH ; CHOOSE FROM EXISTING 124.3 ENTRIES
+1 IF @GMRGXREF>0
WRITE !!,"The following is a list of previous "_$PIECE(GMRGRT,"^",2)_$EXTRACT("s",("Ss"'[$EXTRACT($PIECE(GMRGRT,"^",2),$LENGTH($PIECE(GMRGRT,"^",2))))),!
if GMRGXREF="GMRGXERR"
WRITE "that have been entered in error",!
+2 FOR GMRGZ=0:0
SET GMRGZ=$ORDER(@(GMRGXREF_"("_GMRGZ_")"))
if GMRGZ'>0
QUIT
SET GMRGX=((GMRGZ#10)=1&(GMRGZ'=1))
SET X=""
if GMRGX
WRITE !,"'^' TO STOP: "
if GMRGX
READ X:DTIME
if GMRGX&(X="^^"!'$TEST)
SET GMRGOUT=1
if (X="^"!GMRGOUT)&GMRGX
QUIT
DO PRTC
+3 IF GMRGOUT
if GMRGXREF="GMRGXERR"
QUIT
GOTO Q1
+4 WRITE !!,"Enter Selection: "
+5 READ GMRGX:DTIME
if '$TEST
SET GMRGX="^^"
+6 IF "^^"[GMRGX
if GMRGX="^^"!(GMRGX="^")
SET GMRGOUT=1
if GMRGXREF="GMRGXERR"
QUIT
GOTO Q1
+7 if GMRGX?1L
SET GMRGX=$CHAR($ASCII(GMRGX)-32)
if GMRGXREF="GMRGXERR"&(GMRGX'?1N.N)!(GMRGX["@"&'$PIECE(GMRGXPRT,"^",3))
SET GMRGX="??"
+8 IF '(GMRGX?1N.N."@"!(GMRGX="N"&$PIECE(GMRGXPRT,"^",2))!(GMRGX="E"&$PIECE(GMRGXPRT,"^")))
WRITE !?3,$CHAR(7),"ENTER THE NUMBER OF THE SELECTION TO BE CHOSEN"
if $PIECE(GMRGXPRT,"^",3)
WRITE ",",!?3,"OR THE NUMBER FOLLOWED BY AN '@' TO DELETE A SELECTION"
+9 IF $TEST
if GMRGXREF'="GMRGXERR"&$PIECE(GMRGXPRT,"^",2)
WRITE ",",!?3,"OR THE LETTER 'N' TO ADD A NEW ",$PIECE(GMRGRT,"^",2)
if GMRGXREF'="GMRGXERR"&$PIECE(GMRGXPRT,"^")
WRITE ",",!?3,"OR TYPE AN 'E' TO LIST THE PLANS ENTERED IN ERROR"
WRITE "."
GOTO CPCH
+10 IF GMRGX?1N.N."@"
IF (+GMRGX<1!(+GMRGX>@GMRGXREF))
WRITE !?3,$CHAR(7),"Select a number in the range 1"_$SELECT(@GMRGXREF>1:"-"_@GMRGXREF,1:"")
GOTO CPCH
+11 IF "Ee"[GMRGX
SET GMRGXREF="GMRGXERR"
if @GMRGXREF>0
DO CPCH
if @GMRGXREF'>0
WRITE !?5,$CHAR(7),"THERE ARE NO RECORDS ENTERED IN ERROR, TRY AGAIN."
SET GMRGXREF="GMRGXSEL"
if GMRGPDA>0!GMRGOUT
GOTO Q1
GOTO CPCH
+12 IF "Nn"[GMRGX
DO NEWCP
GOTO Q1
+13 IF GMRGX["@"
DO DELPL
if GMRGOUT
GOTO Q1
if +GMRGX<0
GOTO CPCH
+14 SET GMRGPDA=$PIECE(@(GMRGXREF_"("_+GMRGX_")"),"^",2)_$SELECT(GMRGX'["@":"",1:"^@")
if GMRGXREF="GMRGXERR"
QUIT
Q1 KILL %,DA,DIC,DIE,DR,GMRGXERR,GMRGXPRT,GMRGXREF,GMRGXSEL,GMRGX,GMRGY,GMRGZ,X,Y
QUIT
PRTC ; PRINT AN ENTRY FROM FILE 124.3
+1 WRITE !,$JUSTIFY(GMRGZ,3,0),". "
SET Y=$PIECE(@(GMRGXREF_"("_GMRGZ_")"),"^")
DO DT^DIQ
SET GMRGY=$SELECT($DATA(^GMR(124.3,$PIECE(@(GMRGXREF_"("_GMRGZ_")"),"^",2),0)):$PIECE(^(0),"^",5),1:"")
SET GMRGY=$SELECT(GMRGY="":"",$DATA(^VA(200,GMRGY,0)):$PIECE(^(0),"^"),1:"")
WRITE ?30,GMRGY
+2 QUIT
NEWCP ; ADD A NEW 124.3 ENTRY
+1 DO NOW^%DTC
WRITE !,"Let me create a new record..."
SET GMRGX=%
SET X=+GMRGRT
SET DIC="^GMR(124.3,"
SET DIC(0)="Q"
SET DIC("DR")=".02///^S X=""`""_DFN;.03///^S X=GMRGX"
KILL DD
DO FILE^DICN
SET GMRGPDA=+Y
+2 QUIT
DELPL ; ENTER A 124.3 ENTRY IN ERROR
+1 WRITE !,?3,$CHAR(7),"ARE YOU SURE YOU WANT TO ENTER THIS ",$PIECE(GMRGRT,"^",2)," IN ERROR"
SET %=0
DO YN^DICN
IF '%
WRITE !?5,$CHAR(7),"Answer Yes to enter this selection in error, else answer No."
GOTO DELPL
+2 if %=-1
SET GMRGOUT=1
if %=2
SET GMRGX=-1
if %'=1
QUIT
+3 SET DA=$PIECE(GMRGXSEL(+GMRGX),"^",2)
SET DIE="^GMR(124.3,"
SET DR="5///1"
DO ^DIE
WRITE "."
+4 QUIT
STRY ; SET UP GMRGXSEL( AND GMRGXERR( OF 124.3 ENTRIES TO BE SELECTED
+1 SET X=$SELECT($DATA(^GMR(124.3,+GMRGY,5)):+^(5),1:0)
if X&'$PIECE(GMRGXPRT,"^")
QUIT
+2 IF 'X
SET GMRGXSEL(GMRGZ)=(9999999-GMRGX)_"^"_GMRGY
SET GMRGZ=GMRGZ+1
+3 IF X
SET GMRGXERR(GMRGZ(0))=(9999999-GMRGX)_"^"_GMRGY
SET GMRGZ(0)=GMRGZ(0)+1
+4 QUIT
EN4 ; PRUNE A SUBTREE FROM SOME PATIENT DATA SET
+1 ; GMRGPDA=ENTRY IN FILE 124.3
+2 ; GMRGTERM=ENTRY IN FILE 124.2 WHICH IS THE ROOT OF THE SUBTREE
+3 if '$DATA(GMRGPDA)!'$DATA(GMRGTERM)
GOTO Q4
+4 SET X=GMRGTERM
NEW GMRGTERM,GMRGOUT,GMRGPRC,GMRGRT,GMRGX,GMRGZZ
SET GMRGTERM=X
+5 SET GMRGTERM(0)=$GET(^GMRD(124.2,+GMRGTERM,0))
SET GMRGX=$GET(^GMR(124.3,+GMRGPDA,0))
if GMRGTERM(0)=""!(GMRGX="")
GOTO Q4
+6 SET GMRGRT=+GMRGX_"^"_$PIECE($GET(^GMRD(124.2,+GMRGX,0)),"^")
SET GMRGOUT=0
DO PTDATA
+7 IF +GMRGTERM'=+GMRGRT
DO DELETE^GMRGED6
GOTO Q4
+8 FOR GMRGZZ=0:0
SET GMRGZZ=$ORDER(^GMRD(124.2,+GMRGRT,1,GMRGZZ))
if GMRGZZ'>0
QUIT
SET GMRGTERM=+$GET(^GMRD(124.2,+GMRGRT,1,GMRGZZ,0))
SET GMRGTERM(0)=$GET(^GMRD(124.2,+GMRGTERM,0))
IF +GMRGTERM
DO PTDATA
DO DELETE^GMRGED6
Q4 ;
+1 QUIT
PTDATA ;
+1 SET GMRGX=$ORDER(^GMR(124.3,GMRGPDA,1,"B",GMRGTERM,0))
SET GMRGX(0)=$PIECE($GET(^GMR(124.3,GMRGPDA,1,+GMRGX,0)),"^",2)
SET GMRGPRC=GMRGTERM_"^@^11"
SET GMRGPRC(0)=$PIECE(GMRGTERM(0),"^")_"^"_GMRGX_"^"_GMRGX(0)
+2 QUIT
