- 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 Dec 13, 2024@02:38:16 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