GMRPNOR1 ;SLC/MKB/DJP Progress Note- OE/RR interface;; 2-14-97 ; 7-DEC-1999 12:10:24
;;2.5;Progress Notes;**25,45,50**;Jan 08, 1993
;
; this rtn is needed by TIU to support the one letter CWAD indicators
; in OE/RR 2.5 screens- subroutine CWAD
; DO NOT delete this rtn when the GMRP* rtns are deleted in the
; TIU clean-up
;
SELPT ;select new patient using IN^OR to update ORVP, etc. GMRP*2.5*50
; IN^OR doesn't exist, code no longer used
;K DIC,Y,DIROUT S GMRPOLD=$G(ORVP)
;D IN^OR I $D(DIROUT) S GMRPEND=1 Q
;I (ORVP=GMRPOLD) S XQORM("B")="Redisplay Screen" K GMRPOLD Q
;K GMRPOLD D PAT Q:$D(GMRPQT) S:'$D(GMRPCTXT) GMRPCTXT=1
;D @("BUILD"_GMRPCTXT_"^GMRPNOR"),SCREEN^GMRPNOR
;Q
PAT ;set up patient info for use - expects ORVP or DFN
S GMRPDFN=$S($D(ORVP):$P(ORVP,";"),$D(DFN):DFN,1:0)
I +GMRPDFN'>0 D Q:$D(GMRPQT)
.S DIC="^DPT(",DIC(0)="AEQM" D ^DIC K DIC
.I +Y<1 S GMRPQT=1 Q
.S GMRPDFN=+Y
N DFN S DFN=+GMRPDFN D OERR^VADPT
S $P(GMRPDFN,U,2)=VADM(1),GMRPSSN=VA("PID")
S GMRPDOB=VADM(3),GMRPAGE=VADM(4),GMRPRB=VAIN(5),GMRPLOC=$P(VAIN(4),U)
S GMRPLOC=$P($G(^DIC(42,+GMRPLOC,44)),U)
S:GMRPLOC>0 $P(GMRPLOC,U,2)=$P(^SC(+GMRPLOC,0),U)
K VAIN,VADM,GMRPCWAD S GMRPCWAD=$$CWAD(GMRPDFN)
Q
CWAD(GMRPDFN) ;;check if any clinical warnings exist for patient
;Returns GMRPCWAD="CWAD" (for ones found), or "" if none
;S DFN (below) needed for hidden action CWAD^TIULX
; N GMRPCWAD,GMRPCWA1,TIUST,GMRPALG,GMRPI
N GMRPCWA1,GMRPI
I '+GMRPDFN Q ""
S GMRPCWAD=""
S GMRPCWA1=""
F GMRPI=7,8 D
. I $D(^TIU(8925,"ADCPT",+GMRPDFN,30,GMRPI)) S GMRPCWA1=GMRPCWA1_"C"
. I $D(^TIU(8925,"ADCPT",+GMRPDFN,31,GMRPI)) S GMRPCWA1=GMRPCWA1_"W"
. I $D(^TIU(8925,"ADCPT",+GMRPDFN,27,GMRPI)) S GMRPCWA1=GMRPCWA1_"D"
. Q
S DFN=GMRPDFN D ALLERGY^GMRPNCW I $D(GMRPALG) S GMRPCWA1=GMRPCWA1_"A"
F GMRPI="C","W","D","A" D
. I GMRPCWA1[GMRPI S GMRPCWAD=GMRPCWAD_GMRPI
K CWA,TIUST,GMRPALG
Q GMRPCWAD
;
QUIT ;quits out of review screen
S GMRPEND=1
Q
SEL ;selects single note from screen -- assumes GMRPN(GMRPNN) array
S DIR(0)="NAO^1:"_GMRPNN,DIR("A")="Select a note: "
S DIR("?")="Enter the display number of the note you wish to amend."
S DIR("??")="^D HELPASK1^GMRPND" D ^DIR K DIR
I $D(DTOUT)!($D(DIRUT))!($D(DIROUT)) S GMRPQT=1 Q
S GMRPIFN=GMRPN(+Y)
I $D(GMRPADDM),$P($G(^GMR(121,GMRPIFN,5)),U)=1 D Q
.W !!,"This note requires a cosignature before it may be amended!"
.W $C(7) S GMRPQT=1 K GMRPIFN
D DISPL^GMRPN2 K:'$D(DIROUT)&('$D(DTOUT)) GMRPQT,DUOUT
Q
CURR ;Redisplay current screen -- needs GMRPPG & calls SCREEN
I $S('$D(GMRPPG):1,GMRPPG'>0:1,1:0) S GMRPPG=1
D SCREEN^GMRPNOR
Q
NEXT ;Display next screen -- needs GMRPPG & calls SCREEN
I $S('$D(GMRPPG):1,GMRPPG'>0:1,1:0) S GMRPPG=1
I GMRPPG<GMRPN("PG") S GMRPPG=GMRPPG+1
D SCREEN^GMRPNOR
Q
PREV ;Display previous screen -- needs GMRPPG & calls SCREEN
I $S('$D(GMRPPG):1,GMRPPG'>0:1,1:0) S GMRPPG=1
I GMRPPG>1 S GMRPPG=GMRPPG-1
D SCREEN^GMRPNOR
Q
CTXT ;Select new context for viewing/acting on notes
;Requires/Returns GMRPCTXT
S DIR(0)="SAO^1:SIGNED;2:UNSIGNED;3:UNCOSIGNED;4:AUTHOR;5:DATES"
S DIR("A")="Select context: ",DIR("A",1)="Valid selections are:"
S DIR("A",2)=" 1 - signed notes (all) 2 - unsigned notes 3 - uncosigned notes"
S DIR("A",3)=" 4 - signed notes/author 5 - signed notes/dates",DIR("A",4)=" "
S DIR("?",1)="To change which notes are displayed, select the number"
S DIR("?")="of the context you wish to work within.",DIR("B")="1"
W ! D ^DIR K DIR S:$D(DIROUT) GMRPEND=1
Q:$D(DUOUT)!($D(DTOUT))!($D(DIROUT))
S GMRPSAV=Y D AUTHOR:Y=4,DATES^GMRPNP:Y=5 Q:$D(GMRPQT)
S GMRPCTXT=GMRPSAV K GMRPBLD,GMRPSAV
Q
AUTHOR ;selects author - Returns GMRPDUZ=#^NAME or GMRPQT
S DIC="^VA(200,",DIC(0)="AEQM",DIC("A")="Select AUTHOR: "
S DIC("B")=$P(^VA(200,DUZ,0),U) D ^DIC K DIC
I '$T!(+Y<1) S GMRPQT=1 S:$D(DIROUT) GMRPEND=1 Q
S GMRPDUZ=Y K GMRPQT
Q
SETERM ;sets up GMRPTRML variable to hi-lite <CWAD> flag on review screen
;node 5 = inverse display, node 7 = highlighted display
S GMRPTRML="" Q:'$D(IOST) Q:'$L(IOST)
S X=$O(^%ZIS(2,"B",IOST,0))
;I X,$D(^%ZIS(2,X)) S GMRPTRML=$S($D(^(X,5)):$P(^(5),U,4,5),1:"")
I X,$D(^%ZIS(2,X)) S GMRPTRML=$S($D(^(X,7)):$P(^(7),U,1,3),1:"")
I S:'$L($P(GMRPTRML,U,3)) $P(GMRPTRML,U,3)=$P(GMRPTRML,U,2)
F GMRPI=1,3 I '$L($P(GMRPTRML,U,GMRPI)) S GMRPTRML="" Q
K GMRPI Q
INV() I '$L(X) Q ""
N DX,DY S DX=$X,DY=$Y W @X X ^%ZOSF("XY")
Q ""
UNSIGN ;entry point for follow-up action on unsigned pn's
N ORVP S XQAKILL=0
S GMRPCTXT=2,ORVP=$P($G(XQAID),",",2)_";DPT("
S X=$O(^ORD(101,"B","GMRP REVIEW SCREEN",0))_";ORD(101," D EN^XQOR ;WPB/CAM REMOVE B START OF LINE
Q
COSIGN ;entry point for follow-up action on uncosigned pn's
N ORVP S XQAKILL=0
S GMRPCTXT=3,ORVP=$P($G(XQAID),",",2)_";DPT("
S X=$O(^ORD(101,"B","GMRP REVIEW SCREEN",0))_";ORD(101," D EN^XQOR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRPNOR1 4947 printed Oct 16, 2024@18:38:54 Page 2
GMRPNOR1 ;SLC/MKB/DJP Progress Note- OE/RR interface;; 2-14-97 ; 7-DEC-1999 12:10:24
+1 ;;2.5;Progress Notes;**25,45,50**;Jan 08, 1993
+2 ;
+3 ; this rtn is needed by TIU to support the one letter CWAD indicators
+4 ; in OE/RR 2.5 screens- subroutine CWAD
+5 ; DO NOT delete this rtn when the GMRP* rtns are deleted in the
+6 ; TIU clean-up
+7 ;
SELPT ;select new patient using IN^OR to update ORVP, etc. GMRP*2.5*50
+1 ; IN^OR doesn't exist, code no longer used
+2 ;K DIC,Y,DIROUT S GMRPOLD=$G(ORVP)
+3 ;D IN^OR I $D(DIROUT) S GMRPEND=1 Q
+4 ;I (ORVP=GMRPOLD) S XQORM("B")="Redisplay Screen" K GMRPOLD Q
+5 ;K GMRPOLD D PAT Q:$D(GMRPQT) S:'$D(GMRPCTXT) GMRPCTXT=1
+6 ;D @("BUILD"_GMRPCTXT_"^GMRPNOR"),SCREEN^GMRPNOR
+7 ;Q
PAT ;set up patient info for use - expects ORVP or DFN
+1 SET GMRPDFN=$SELECT($DATA(ORVP):$PIECE(ORVP,";"),$DATA(DFN):DFN,1:0)
+2 IF +GMRPDFN'>0
Begin DoDot:1
+3 SET DIC="^DPT("
SET DIC(0)="AEQM"
DO ^DIC
KILL DIC
+4 IF +Y<1
SET GMRPQT=1
QUIT
+5 SET GMRPDFN=+Y
End DoDot:1
if $DATA(GMRPQT)
QUIT
+6 NEW DFN
SET DFN=+GMRPDFN
DO OERR^VADPT
+7 SET $PIECE(GMRPDFN,U,2)=VADM(1)
SET GMRPSSN=VA("PID")
+8 SET GMRPDOB=VADM(3)
SET GMRPAGE=VADM(4)
SET GMRPRB=VAIN(5)
SET GMRPLOC=$PIECE(VAIN(4),U)
+9 SET GMRPLOC=$PIECE($GET(^DIC(42,+GMRPLOC,44)),U)
+10 if GMRPLOC>0
SET $PIECE(GMRPLOC,U,2)=$PIECE(^SC(+GMRPLOC,0),U)
+11 KILL VAIN,VADM,GMRPCWAD
SET GMRPCWAD=$$CWAD(GMRPDFN)
+12 QUIT
CWAD(GMRPDFN) ;;check if any clinical warnings exist for patient
+1 ;Returns GMRPCWAD="CWAD" (for ones found), or "" if none
+2 ;S DFN (below) needed for hidden action CWAD^TIULX
+3 ; N GMRPCWAD,GMRPCWA1,TIUST,GMRPALG,GMRPI
+4 NEW GMRPCWA1,GMRPI
+5 IF '+GMRPDFN
QUIT ""
+6 SET GMRPCWAD=""
+7 SET GMRPCWA1=""
+8 FOR GMRPI=7,8
Begin DoDot:1
+9 IF $DATA(^TIU(8925,"ADCPT",+GMRPDFN,30,GMRPI))
SET GMRPCWA1=GMRPCWA1_"C"
+10 IF $DATA(^TIU(8925,"ADCPT",+GMRPDFN,31,GMRPI))
SET GMRPCWA1=GMRPCWA1_"W"
+11 IF $DATA(^TIU(8925,"ADCPT",+GMRPDFN,27,GMRPI))
SET GMRPCWA1=GMRPCWA1_"D"
+12 QUIT
End DoDot:1
+13 SET DFN=GMRPDFN
DO ALLERGY^GMRPNCW
IF $DATA(GMRPALG)
SET GMRPCWA1=GMRPCWA1_"A"
+14 FOR GMRPI="C","W","D","A"
Begin DoDot:1
+15 IF GMRPCWA1[GMRPI
SET GMRPCWAD=GMRPCWAD_GMRPI
End DoDot:1
+16 KILL CWA,TIUST,GMRPALG
+17 QUIT GMRPCWAD
+18 ;
QUIT ;quits out of review screen
+1 SET GMRPEND=1
+2 QUIT
SEL ;selects single note from screen -- assumes GMRPN(GMRPNN) array
+1 SET DIR(0)="NAO^1:"_GMRPNN
SET DIR("A")="Select a note: "
+2 SET DIR("?")="Enter the display number of the note you wish to amend."
+3 SET DIR("??")="^D HELPASK1^GMRPND"
DO ^DIR
KILL DIR
+4 IF $DATA(DTOUT)!($DATA(DIRUT))!($DATA(DIROUT))
SET GMRPQT=1
QUIT
+5 SET GMRPIFN=GMRPN(+Y)
+6 IF $DATA(GMRPADDM)
IF $PIECE($GET(^GMR(121,GMRPIFN,5)),U)=1
Begin DoDot:1
+7 WRITE !!,"This note requires a cosignature before it may be amended!"
+8 WRITE $CHAR(7)
SET GMRPQT=1
KILL GMRPIFN
End DoDot:1
QUIT
+9 DO DISPL^GMRPN2
if '$DATA(DIROUT)&('$DATA(DTOUT))
KILL GMRPQT,DUOUT
+10 QUIT
CURR ;Redisplay current screen -- needs GMRPPG & calls SCREEN
+1 IF $SELECT('$DATA(GMRPPG):1,GMRPPG'>0:1,1:0)
SET GMRPPG=1
+2 DO SCREEN^GMRPNOR
+3 QUIT
NEXT ;Display next screen -- needs GMRPPG & calls SCREEN
+1 IF $SELECT('$DATA(GMRPPG):1,GMRPPG'>0:1,1:0)
SET GMRPPG=1
+2 IF GMRPPG<GMRPN("PG")
SET GMRPPG=GMRPPG+1
+3 DO SCREEN^GMRPNOR
+4 QUIT
PREV ;Display previous screen -- needs GMRPPG & calls SCREEN
+1 IF $SELECT('$DATA(GMRPPG):1,GMRPPG'>0:1,1:0)
SET GMRPPG=1
+2 IF GMRPPG>1
SET GMRPPG=GMRPPG-1
+3 DO SCREEN^GMRPNOR
+4 QUIT
CTXT ;Select new context for viewing/acting on notes
+1 ;Requires/Returns GMRPCTXT
+2 SET DIR(0)="SAO^1:SIGNED;2:UNSIGNED;3:UNCOSIGNED;4:AUTHOR;5:DATES"
+3 SET DIR("A")="Select context: "
SET DIR("A",1)="Valid selections are:"
+4 SET DIR("A",2)=" 1 - signed notes (all) 2 - unsigned notes 3 - uncosigned notes"
+5 SET DIR("A",3)=" 4 - signed notes/author 5 - signed notes/dates"
SET DIR("A",4)=" "
+6 SET DIR("?",1)="To change which notes are displayed, select the number"
+7 SET DIR("?")="of the context you wish to work within."
SET DIR("B")="1"
+8 WRITE !
DO ^DIR
KILL DIR
if $DATA(DIROUT)
SET GMRPEND=1
+9 if $DATA(DUOUT)!($DATA(DTOUT))!($DATA(DIROUT))
QUIT
+10 SET GMRPSAV=Y
if Y=4
DO AUTHOR
if Y=5
DO DATES^GMRPNP
if $DATA(GMRPQT)
QUIT
+11 SET GMRPCTXT=GMRPSAV
KILL GMRPBLD,GMRPSAV
+12 QUIT
AUTHOR ;selects author - Returns GMRPDUZ=#^NAME or GMRPQT
+1 SET DIC="^VA(200,"
SET DIC(0)="AEQM"
SET DIC("A")="Select AUTHOR: "
+2 SET DIC("B")=$PIECE(^VA(200,DUZ,0),U)
DO ^DIC
KILL DIC
+3 IF '$TEST!(+Y<1)
SET GMRPQT=1
if $DATA(DIROUT)
SET GMRPEND=1
QUIT
+4 SET GMRPDUZ=Y
KILL GMRPQT
+5 QUIT
SETERM ;sets up GMRPTRML variable to hi-lite <CWAD> flag on review screen
+1 ;node 5 = inverse display, node 7 = highlighted display
+2 SET GMRPTRML=""
if '$DATA(IOST)
QUIT
if '$LENGTH(IOST)
QUIT
+3 SET X=$ORDER(^%ZIS(2,"B",IOST,0))
+4 ;I X,$D(^%ZIS(2,X)) S GMRPTRML=$S($D(^(X,5)):$P(^(5),U,4,5),1:"")
+5 IF X
IF $DATA(^%ZIS(2,X))
SET GMRPTRML=$SELECT($DATA(^(X,7)):$PIECE(^(7),U,1,3),1:"")
+6 IF $TEST
if '$LENGTH($PIECE(GMRPTRML,U,3))
SET $PIECE(GMRPTRML,U,3)=$PIECE(GMRPTRML,U,2)
+7 FOR GMRPI=1,3
IF '$LENGTH($PIECE(GMRPTRML,U,GMRPI))
SET GMRPTRML=""
QUIT
+8 KILL GMRPI
QUIT
INV() IF '$LENGTH(X)
QUIT ""
+1 NEW DX,DY
SET DX=$X
SET DY=$Y
WRITE @X
XECUTE ^%ZOSF("XY")
+2 QUIT ""
UNSIGN ;entry point for follow-up action on unsigned pn's
+1 NEW ORVP
SET XQAKILL=0
+2 SET GMRPCTXT=2
SET ORVP=$PIECE($GET(XQAID),",",2)_";DPT("
+3 ;WPB/CAM REMOVE B START OF LINE
SET X=$ORDER(^ORD(101,"B","GMRP REVIEW SCREEN",0))_";ORD(101,"
DO EN^XQOR
+4 QUIT
COSIGN ;entry point for follow-up action on uncosigned pn's
+1 NEW ORVP
SET XQAKILL=0
+2 SET GMRPCTXT=3
SET ORVP=$PIECE($GET(XQAID),",",2)_";DPT("
+3 SET X=$ORDER(^ORD(101,"B","GMRP REVIEW SCREEN",0))_";ORD(101,"
DO EN^XQOR
+4 QUIT
