AG ; IHS/ASDS/EFG - INITIAL ROUTINE AND UTILITY SUB-ROUTINES ;
;;7.1;PATIENT REGISTRATION;**1,2,12**;AUG 25, 2005;Build 1
;IHS/OIT/NKD AG*7.1*12 REVISED VERSION/PATCH DISPLAY
;
; ****************************************************************
;
S AG("VERDT")=""
S AG("VERSION")=""
S Y=""
S (AGIEN,Y)=$O(^DIC(9.4,"C","AG",Y))
I Y S AG("VERSION")=^DIC(9.4,Y,"VERSION")
I AG("VERSION")]"" S Y=$O(^DIC(9.4,Y,22,"B",AG("VERSION"),""))
I Y]"" D
. S Y=$P(^DIC(9.4,AGIEN,22,Y,0),U,2)
. D DD^%DT
. S AG("VERDT")=Y
I '$D(IOF) D
. S IOP=ION
. D ^%ZIS
W $$S^AGVDF("IOF"),!?22
F I=1:1:35 W "*"
W !?22,"*",?56,"*"
W !?22,"* INDIAN HEALTH SERVICE *"
W !?22,"* PATIENT REGISTRATION SYSTEM *"
;IHS/OIT/NKD AG*7.1*12 - REVISED DISPLAY - START OLD CODE
;I AG("VERSION")]"" D
;. ;W !?22,"* VERSION ",AG("VERSION"),", ",AG("VERDT"),?56,"*"
;. W !?22,"* VERSION ",AG("VERSION") W ".",$$CURPATCH
;. W ", ",AG("VERDT"),?56,"*"
;IHS/OIT/NKD AG*7.1*12 - END OLD CODE - START NEW CODE
D
. N AGTMP
. S AGTMP=$$LAST^XPDUTL("AG","7.1") I +AGTMP>0 W !?22,"* AG V7.1 P",+AGTMP,", ",$$FMTE^XLFDT($P(AGTMP,"^",2),"5D"),?56,"*"
. S AGTMP=$$LAST^XPDUTL("AG","7.2") I +AGTMP>0 W !?22,"* AGMPI V7.2 P",+AGTMP,", ",$$FMTE^XLFDT($P(AGTMP,"^",2),"5D"),?56,"*"
;IHS/OIT/NKD AG*7.1*12 - END NEW CODE
W !?22,"*",?56,"*",!?22
F I=1:1:35 W "*"
;
SITE ;EP - From options.
I '$D(DUZ(2)) D SET^XBSITE G L4:'$D(DUZ(2))
W !!?80-$L($P(^DIC(4,DUZ(2),0),U))\2,$P(^(0),U)
W !!,$$CJ^XLFSTR("*** NOTE: IF YOU EDIT A PATIENT AND SEE THEIR NAME IN REVERSE VIDEO ***",IOM)
W !,$$CJ^XLFSTR("*** WITH '(RHI)' BLINKING NEXT TO IT, IT MEANS THEY HAVE RESTRICTED ***",IOM)
W !,$$CJ^XLFSTR("*** HEALTH INFORMATION ***",IOM)
;
L4 ;
W !
K AG,I,AG("VERDT"),AG("VERSION")
Q
CURPATCH() ;EP - GET CURRENT PATCH LEVEL FOR HEADER
N %,I,J
S I=$O(^DIC(9.4,"B","IHS PATIENT REGISTRATION",0)) Q:'I 0
S PENTRY=$O(^DIC(9.4,I,22,"B",AG("VERSION"),"")) Q:'PENTRY 0
S PVER=$O(^DIC(9.4,I,22,PENTRY,"PAH","B"),-1) Q:'PVER 0
S PVER=$P($G(^DIC(9.4,I,22,PENTRY,"PAH",PVER,0)),U)
Q PVER
; ****************************************************************
READ ;EP - Standard READ sub-routine for Registration.
K DIRUT ;AG*7.1*2 ISSUE REPORTED DURING ALPHA TESTING
K DFOUT,DTOUT,DUOUT,DQOUT,DLOUT R Y:DTIME I '$T W *7 R Y:5 G READ:Y="." I '$T S (DTOUT,Y)="" Q
S:Y="/.," (DFOUT,Y)=""
S:Y="" DLOUT=""
S:Y="^" (DUOUT,Y)=""
S:Y?1"?".E!(Y[U) (DQOUT,Y)=""
Q
; ****************************************************************
RTRN ;EP
S Y=1
I $E(IOST)="C" D
. S DIR(0)="E"
. D ^DIR
. K DIR
Q
; ****************************************************************
NOW ;EP - Set AGTIME to time now.
D NOW^%DTC
S Y=%
D DD^%DT
S AGTIME=Y
Q
; ****************************************************************
LINE ;EP - Standard writeline sub-routine.
W !
F AG("LI")=1:1:78 W AG("LINE")
W !
Q
; ****************************************************************
LINES ;EP "Standard" lines of characters.
S AG("-")=""
S $P(AG("-"),"-",80)=""
S AG("=")=""
S $P(AG("="),"=",80)=""
S AG("*")=""
S $P(AG("*"),"*",80)=""
Q
; ****************************************************************
CTR ;EP - Center X.
S X=$J("",80-$L(X)\2)_X
Q
; ****************************************************************
YN ;EP
W !!,"Enter a ""Y"" for YES or an ""N"" for NO."
Q
; ****************************************************************
KILL ;PEP - USED BY TPB TO CLEAN UP VARIABLES
K ^UTILITY("DIQ1",$J)
K %DT,A,AG,AGCHRT,AGI,AGLINE,AGOPT,AGPAT,AGSITE,AGUPDT
K C,DFN,AG("DENT"),DFOUT,DIC,DIE,DLOUT,DTOUT,DQOUT,DUOUT,G,AGL,I,L
K AGNEW,AGPCC,AGSCRN,AGTEMP,AG("TRBCODE"),X,XY,XYER,Y
K AGAIN
K AGSELECT
Q
; ****************************************************************
VIDEO ;EP
S XY=$G(^%ZIS(2,IOST(0),"XY")),XYER=$P($G(^(5)),"^",6)
I XYER]"" S XYER="W "_XYER
Q
; ****************************************************************
PTLK ;EP - Standard pt lookup using DIC.
K DFN,RHIFLAG
K DIC
;ENTER HERE IF YOU WISH TO KILL DIC YOURSELF
PTLKNKIL ;
S DIC="^AUPNPAT("
S DIC(0)="AEMQ"
D ^DIC
;I Y'=-1 S DFN=+Y D CHKRHI^AG
I Y'=-1 S (AGPATDFN,DFN)=+Y D CHKRHI^AG ;IHS/SD/TPF AG*7.1*1 FIX PROBLEM WITH CURRENT PAT. IN EDIT SCREEN CHANGING WHEN PATIENT LOOKUP IS USED (DFN CHANGES)
I $D(RHIFLAG) D
. I RHIFLAG="A" W !,$$S^AGVDF("RVN"),$$S^AGVDF("BLN"),"This patient has Restricted Health Information",$$S^AGVDF("BLF"),$$S^AGVDF("RVF")
;ADD ALERT IF PATIENT HAS 'DATE OF DEATH' POPULATED IN VA
;PATIENT FILE
I $D(DFN) I $$CHKDEATH^AGEDERR(DFN) W !!?5,"**** ALERT: DATE OF DEATH ON FILE FOR THIS PATIENT!!" H 2
Q
; ****************************************************************
HDR ;EP - Print menu header.
K AGNEWINS,DIR
D:'$D(AGOPT) ^AGVAR
I $D(X) S X=$P(^DIC(19,$O(^DIC(19,"B",X,0)),0),U,2)
S Y="AG"
G SHDR
; ****************************************************************
PHDR ;EP - Print parent menu header.
D:$D(AGOPT) KILL
I ^XUTL("XQ",$J,"T")=1 Q
I ^XUTL("XQ",$J,^XUTL("XQ",$J,"T")-1)=-1 Q
S X=$P(^DIC(19,+^XUTL("XQ",$J,^XUTL("XQ",$J,"T")-1),0),U,2)
S Y=$P(^DIC(19,+^XUTL("XQ",$J,^XUTL("XQ",$J,"T")-1),0),U)
I Y="AGMASTER" D ^AG Q
;
SHDR ;EP - Screen header.
I '$D(IOF) D ; defensive for menu jumping
. S IOP="HOME"
. D ^%ZIS
I $D(X) D CTR
W $$S^AGVDF("IOF")
W !!?30,$S($E(Y,1,2)="AG":"PATIENT REGISTRATION",1:"")
W !!?40-($L($P(^DIC(4,DUZ(2),0),U))\2),$P(^(0),U)
I $D(X) W !!,X,!
Q:$D(AG("RPT"))
W !!,$$CJ^XLFSTR("*** NOTE: IF YOU EDIT A PATIENT AND SEE THEIR NAME IN REVERSE VIDEO ***",IOM)
W !,$$CJ^XLFSTR("*** WITH '(RHI)' BLINKING NEXT TO IT, IT MEANS THEY HAVE RESTRICTED ***",IOM)
W !,$$CJ^XLFSTR("*** HEALTH INFORMATION ***",IOM)
Q
; ****************************************************************
CPI ;EP
W !?21,"*** CONFIDENTIAL PATIENT INFORMATION ***"
Q
; ****************************************************************
DFNTR ;EP - External Packages
;check transmission required fields for patient DFN
D ^AGDATCK
D ^AGBADATA
K AG,AGOPT,AGQI,AGQT,AGTP
Q
; ****************************************************************
T ;EP - DISPLAY TIME IN HH:MM (AM/PM) FORMAT
D NOW^%DTC
S AG("TIME")=$P(%,".",2)
S AG("HOUR")=$E(AG("TIME"),1,2)
S AG("MINUTE")=$E(AG("TIME"),3,4)
S AG("AMPM")="AM"
I AG("HOUR")>11 D
.S AG("AMPM")="PM"
.I AG("HOUR")>12 S AG("HOUR")=AG("HOUR")-12
W $J(+AG("HOUR"),2),":",AG("MINUTE")," ",AG("AMPM")
Q
; ****************************************************************
CHKNPP ;EP - CHECK PATIENT FOR NOTICE OF PRIVACY PRACTICES ENTRY
K REC,NPPFLAG
S REC=$O(^AUPNNPP("B",DFN,""),-1)
Q:REC=""
S NPPFLAG=""
Q
CHKRHI ;EP - CHECK PATIENT FOR RESTRICTED HEALTH INFORMATION
Q:'$D(DFN)
S REC=0 S RHIFLAG=""
F S REC=$O(^AUPNRHI("B",DFN,REC)) Q:'REC D
. I $P($G(^AUPNRHI(REC,0)),U,3)="A" S RHIFLAG="A"
Q
AG ; IHS/ASDS/EFG - INITIAL ROUTINE AND UTILITY SUB-ROUTINES ;
+1 ;;7.1;PATIENT REGISTRATION;**1,2,12**;AUG 25, 2005;Build 1
+2 ;IHS/OIT/NKD AG*7.1*12 REVISED VERSION/PATCH DISPLAY
+3 ;
+4 ; ****************************************************************
+5 ;
+6 SET AG("VERDT")=""
+7 SET AG("VERSION")=""
+8 SET Y=""
+9 SET (AGIEN,Y)=$ORDER(^DIC(9.4,"C","AG",Y))
+10 IF Y
SET AG("VERSION")=^DIC(9.4,Y,"VERSION")
+11 IF AG("VERSION")]""
SET Y=$ORDER(^DIC(9.4,Y,22,"B",AG("VERSION"),""))
+12 IF Y]""
Begin DoDot:1
+13 SET Y=$PIECE(^DIC(9.4,AGIEN,22,Y,0),U,2)
+14 DO DD^%DT
+15 SET AG("VERDT")=Y
End DoDot:1
+16 IF '$DATA(IOF)
Begin DoDot:1
+17 SET IOP=ION
+18 DO ^%ZIS
End DoDot:1
+19 WRITE $$S^AGVDF("IOF"),!?22
+20 FOR I=1:1:35
WRITE "*"
+21 WRITE !?22,"*",?56,"*"
+22 WRITE !?22,"* INDIAN HEALTH SERVICE *"
+23 WRITE !?22,"* PATIENT REGISTRATION SYSTEM *"
+24 ;IHS/OIT/NKD AG*7.1*12 - REVISED DISPLAY - START OLD CODE
+25 ;I AG("VERSION")]"" D
+26 ;. ;W !?22,"* VERSION ",AG("VERSION"),", ",AG("VERDT"),?56,"*"
+27 ;. W !?22,"* VERSION ",AG("VERSION") W ".",$$CURPATCH
+28 ;. W ", ",AG("VERDT"),?56,"*"
+29 ;IHS/OIT/NKD AG*7.1*12 - END OLD CODE - START NEW CODE
+30 Begin DoDot:1
+31 NEW AGTMP
+32 SET AGTMP=$$LAST^XPDUTL("AG","7.1")
IF +AGTMP>0
WRITE !?22,"* AG V7.1 P",+AGTMP,", ",$$FMTE^XLFDT($PIECE(AGTMP,"^",2),"5D"),?56,"*"
+33 SET AGTMP=$$LAST^XPDUTL("AG","7.2")
IF +AGTMP>0
WRITE !?22,"* AGMPI V7.2 P",+AGTMP,", ",$$FMTE^XLFDT($PIECE(AGTMP,"^",2),"5D"),?56,"*"
End DoDot:1
+34 ;IHS/OIT/NKD AG*7.1*12 - END NEW CODE
+35 WRITE !?22,"*",?56,"*",!?22
+36 FOR I=1:1:35
WRITE "*"
+37 ;
SITE ;EP - From options.
+1 IF '$DATA(DUZ(2))
DO SET^XBSITE
IF '$DATA(DUZ(2))
GOTO L4
+2 WRITE !!?80-$LENGTH($PIECE(^DIC(4,DUZ(2),0),U))\2,$PIECE(^(0),U)
+3 WRITE !!,$$CJ^XLFSTR("*** NOTE: IF YOU EDIT A PATIENT AND SEE THEIR NAME IN REVERSE VIDEO ***",IOM)
+4 WRITE !,$$CJ^XLFSTR("*** WITH '(RHI)' BLINKING NEXT TO IT, IT MEANS THEY HAVE RESTRICTED ***",IOM)
+5 WRITE !,$$CJ^XLFSTR("*** HEALTH INFORMATION ***",IOM)
+6 ;
L4 ;
+1 WRITE !
+2 KILL AG,I,AG("VERDT"),AG("VERSION")
+3 QUIT
CURPATCH() ;EP - GET CURRENT PATCH LEVEL FOR HEADER
+1 NEW %,I,J
+2 SET I=$ORDER(^DIC(9.4,"B","IHS PATIENT REGISTRATION",0))
IF 'I
QUIT 0
+3 SET PENTRY=$ORDER(^DIC(9.4,I,22,"B",AG("VERSION"),""))
IF 'PENTRY
QUIT 0
+4 SET PVER=$ORDER(^DIC(9.4,I,22,PENTRY,"PAH","B"),-1)
IF 'PVER
QUIT 0
+5 SET PVER=$PIECE($GET(^DIC(9.4,I,22,PENTRY,"PAH",PVER,0)),U)
+6 QUIT PVER
+7 ; ****************************************************************
READ ;EP - Standard READ sub-routine for Registration.
+1 ;AG*7.1*2 ISSUE REPORTED DURING ALPHA TESTING
KILL DIRUT
+2 KILL DFOUT,DTOUT,DUOUT,DQOUT,DLOUT
READ Y:DTIME
IF '$TEST
WRITE *7
READ Y:5
IF Y="."
GOTO READ
IF '$TEST
SET (DTOUT,Y)=""
QUIT
+3 IF Y="/.,"
SET (DFOUT,Y)=""
+4 IF Y=""
SET DLOUT=""
+5 IF Y="^"
SET (DUOUT,Y)=""
+6 IF Y?1"?".E!(Y[U)
SET (DQOUT,Y)=""
+7 QUIT
+8 ; ****************************************************************
RTRN ;EP
+1 SET Y=1
+2 IF $EXTRACT(IOST)="C"
Begin DoDot:1
+3 SET DIR(0)="E"
+4 DO ^DIR
+5 KILL DIR
End DoDot:1
+6 QUIT
+7 ; ****************************************************************
NOW ;EP - Set AGTIME to time now.
+1 DO NOW^%DTC
+2 SET Y=%
+3 DO DD^%DT
+4 SET AGTIME=Y
+5 QUIT
+6 ; ****************************************************************
LINE ;EP - Standard writeline sub-routine.
+1 WRITE !
+2 FOR AG("LI")=1:1:78
WRITE AG("LINE")
+3 WRITE !
+4 QUIT
+5 ; ****************************************************************
LINES ;EP "Standard" lines of characters.
+1 SET AG("-")=""
+2 SET $PIECE(AG("-"),"-",80)=""
+3 SET AG("=")=""
+4 SET $PIECE(AG("="),"=",80)=""
+5 SET AG("*")=""
+6 SET $PIECE(AG("*"),"*",80)=""
+7 QUIT
+8 ; ****************************************************************
CTR ;EP - Center X.
+1 SET X=$JUSTIFY("",80-$LENGTH(X)\2)_X
+2 QUIT
+3 ; ****************************************************************
YN ;EP
+1 WRITE !!,"Enter a ""Y"" for YES or an ""N"" for NO."
+2 QUIT
+3 ; ****************************************************************
KILL ;PEP - USED BY TPB TO CLEAN UP VARIABLES
+1 KILL ^UTILITY("DIQ1",$JOB)
+2 KILL %DT,A,AG,AGCHRT,AGI,AGLINE,AGOPT,AGPAT,AGSITE,AGUPDT
+3 KILL C,DFN,AG("DENT"),DFOUT,DIC,DIE,DLOUT,DTOUT,DQOUT,DUOUT,G,AGL,I,L
+4 KILL AGNEW,AGPCC,AGSCRN,AGTEMP,AG("TRBCODE"),X,XY,XYER,Y
+5 KILL AGAIN
+6 KILL AGSELECT
+7 QUIT
+8 ; ****************************************************************
VIDEO ;EP
+1 SET XY=$GET(^%ZIS(2,IOST(0),"XY"))
SET XYER=$PIECE($GET(^(5)),"^",6)
+2 IF XYER]""
SET XYER="W "_XYER
+3 QUIT
+4 ; ****************************************************************
PTLK ;EP - Standard pt lookup using DIC.
+1 KILL DFN,RHIFLAG
+2 KILL DIC
+3 ;ENTER HERE IF YOU WISH TO KILL DIC YOURSELF
PTLKNKIL ;
+1 SET DIC="^AUPNPAT("
+2 SET DIC(0)="AEMQ"
+3 DO ^DIC
+4 ;I Y'=-1 S DFN=+Y D CHKRHI^AG
+5 ;IHS/SD/TPF AG*7.1*1 FIX PROBLEM WITH CURRENT PAT. IN EDIT SCREEN CHANGING WHEN PATIENT LOOKUP IS USED (DFN CHANGES)
IF Y'=-1
SET (AGPATDFN,DFN)=+Y
DO CHKRHI^AG
+6 IF $DATA(RHIFLAG)
Begin DoDot:1
+7 IF RHIFLAG="A"
WRITE !,$$S^AGVDF("RVN"),$$S^AGVDF("BLN"),"This patient has Restricted Health Information",$$S^AGVDF("BLF"),$$S^AGVDF("RVF")
End DoDot:1
+8 ;ADD ALERT IF PATIENT HAS 'DATE OF DEATH' POPULATED IN VA
+9 ;PATIENT FILE
+10 IF $DATA(DFN)
IF $$CHKDEATH^AGEDERR(DFN)
WRITE !!?5,"**** ALERT: DATE OF DEATH ON FILE FOR THIS PATIENT!!"
HANG 2
+11 QUIT
+12 ; ****************************************************************
HDR ;EP - Print menu header.
+1 KILL AGNEWINS,DIR
+2 IF '$DATA(AGOPT)
DO ^AGVAR
+3 IF $DATA(X)
SET X=$PIECE(^DIC(19,$ORDER(^DIC(19,"B",X,0)),0),U,2)
+4 SET Y="AG"
+5 GOTO SHDR
+6 ; ****************************************************************
PHDR ;EP - Print parent menu header.
+1 IF $DATA(AGOPT)
DO KILL
+2 IF ^XUTL("XQ",$JOB,"T")=1
QUIT
+3 IF ^XUTL("XQ",$JOB,^XUTL("XQ",$JOB,"T")-1)=-1
QUIT
+4 SET X=$PIECE(^DIC(19,+^XUTL("XQ",$JOB,^XUTL("XQ",$JOB,"T")-1),0),U,2)
+5 SET Y=$PIECE(^DIC(19,+^XUTL("XQ",$JOB,^XUTL("XQ",$JOB,"T")-1),0),U)
+6 IF Y="AGMASTER"
DO ^AG
QUIT
+7 ;
SHDR ;EP - Screen header.
+1 ; defensive for menu jumping
IF '$DATA(IOF)
Begin DoDot:1
+2 SET IOP="HOME"
+3 DO ^%ZIS
End DoDot:1
+4 IF $DATA(X)
DO CTR
+5 WRITE $$S^AGVDF("IOF")
+6 WRITE !!?30,$SELECT($EXTRACT(Y,1,2)="AG":"PATIENT REGISTRATION",1:"")
+7 WRITE !!?40-($LENGTH($PIECE(^DIC(4,DUZ(2),0),U))\2),$PIECE(^(0),U)
+8 IF $DATA(X)
WRITE !!,X,!
+9 IF $DATA(AG("RPT"))
QUIT
+10 WRITE !!,$$CJ^XLFSTR("*** NOTE: IF YOU EDIT A PATIENT AND SEE THEIR NAME IN REVERSE VIDEO ***",IOM)
+11 WRITE !,$$CJ^XLFSTR("*** WITH '(RHI)' BLINKING NEXT TO IT, IT MEANS THEY HAVE RESTRICTED ***",IOM)
+12 WRITE !,$$CJ^XLFSTR("*** HEALTH INFORMATION ***",IOM)
+13 QUIT
+14 ; ****************************************************************
CPI ;EP
+1 WRITE !?21,"*** CONFIDENTIAL PATIENT INFORMATION ***"
+2 QUIT
+3 ; ****************************************************************
DFNTR ;EP - External Packages
+1 ;check transmission required fields for patient DFN
+2 DO ^AGDATCK
+3 DO ^AGBADATA
+4 KILL AG,AGOPT,AGQI,AGQT,AGTP
+5 QUIT
+6 ; ****************************************************************
T ;EP - DISPLAY TIME IN HH:MM (AM/PM) FORMAT
+1 DO NOW^%DTC
+2 SET AG("TIME")=$PIECE(%,".",2)
+3 SET AG("HOUR")=$EXTRACT(AG("TIME"),1,2)
+4 SET AG("MINUTE")=$EXTRACT(AG("TIME"),3,4)
+5 SET AG("AMPM")="AM"
+6 IF AG("HOUR")>11
Begin DoDot:1
+7 SET AG("AMPM")="PM"
+8 IF AG("HOUR")>12
SET AG("HOUR")=AG("HOUR")-12
End DoDot:1
+9 WRITE $JUSTIFY(+AG("HOUR"),2),":",AG("MINUTE")," ",AG("AMPM")
+10 QUIT
+11 ; ****************************************************************
CHKNPP ;EP - CHECK PATIENT FOR NOTICE OF PRIVACY PRACTICES ENTRY
+1 KILL REC,NPPFLAG
+2 SET REC=$ORDER(^AUPNNPP("B",DFN,""),-1)
+3 IF REC=""
QUIT
+4 SET NPPFLAG=""
+5 QUIT
CHKRHI ;EP - CHECK PATIENT FOR RESTRICTED HEALTH INFORMATION
+1 IF '$DATA(DFN)
QUIT
+2 SET REC=0
SET RHIFLAG=""
+3 FOR
SET REC=$ORDER(^AUPNRHI("B",DFN,REC))
IF 'REC
QUIT
Begin DoDot:1
+4 IF $PIECE($GET(^AUPNRHI(REC,0)),U,3)="A"
SET RHIFLAG="A"
End DoDot:1
+5 QUIT
