AGED11A ; IHS/ASDS/EFG - EDIT DOCUMENT SUMMARY PAGE (PAGE 9) ; MAR 19, 2010
;;7.1;PATIENT REGISTRATION;**1,2,7,8**;AUG 25, 2005
;
;AG*7.1*7 - Modified code to allow the new page 10 to be called
;
VAR D DRAW
Q:$D(AGSEENLY)
K DIR
S DIR("?")="Enter your choice now."
S DIR("?",1)="You may enter the item number of the field you wish to edit,"
S DIR("?",2)="OR you can enter 'P#' where P stands for 'page' and '#' stands for"
S DIR("?",3)="the page you wish to jump to, OR enter '^' to go back one page"
S DIR("?",4)="OR, enter '^^' to exit the edit screens, OR RETURN to go back to the main menu."
S DIR("A")="CHANGE which item? (1-"_AG("N")_") NONE// "
D READ^AGED1
I $D(MYERRS("C","E")),(Y'?1N.N),(Y'=AGOPT("ESCAPE")) W !,"ERRORS ON THIS PAGE. PLEASE FIX BEFORE EXITING!!" H 3 G VAR
Q:Y=AGOPT("ESCAPE")
Q:$D(DTOUT)!$D(DFOUT)
G ^AGED11:$D(DUOUT)&'$D(AGXTERN),VAR:$D(AG("ERR")),END:$D(DLOUT)!(Y["N") G:$D(AG("ED"))&'$D(AGXTERN) @("^AGED"_AG("ED"))
I $D(DQOUT)!(+Y<1)!(+Y>AG("N")) W !!,"You must enter a number from 1 to ",AG("N") H 2 G VAR
W !!
CC ;S AG("C")="EMOD,CHSTAT,PRIVA,LDOC,ADVDIRED,ROI,AOB,NPP,ACK,RHI"
S AG("C")="EMOD,CHSTAT,LDOC,ADVDIRED,ROI,AOB,NPP,ACK,RHI"
C ;EP - Edit multiple fields on a Reg edit page.
S AGY=Y F AGI=1:1 S AG("SEL")=+$P(AGY,",",AGI) Q:AG("SEL")<1!(AG("SEL")>AG("N")) D @($P(AG("C"),",",AG("SEL")))
D UPDATE1^AGED(DUZ(2),DFN,8,"") K AGI,AGY
G VAR
END K AG,DFOUT,DQOUT,DTOUT,DA,DIC,DIE,DR,AGSCRN,Y,NUMCASES,CNT,MOD,MOVDT
K ROUTID
Q:$D(AGXTERN)
Q:$D(DIROUT)
Q:$D(AGSEENLY)
G ^AGED10A
EMOD ;LOOKUP FOR ELIGIBILITY MODIFIER FIELD
N DIC,DA,X,Y,DIR
K DTOUT,DUOUT
S DIR(0)="F"
I $O(^AUPNPAT(DFN,34,0)) S DIR("A")="Do you wish to E(dit) or A(dd) an Eligibility Modifier ? "
E S DIR("A")="Do you wish to A(dd) an Eligibility Modifier ? "
D ^DIR
Q:$D(DTOUT)!(Y="^")
I Y'="E"&(Y'="A") G EMOD
I Y="A" D ADDMOD Q
I Y="E",$O(^AUPNPAT(DFN,34,0)) D EDITMOD Q
Q
ADDMOD ;ADD A NEW MODIFIER TO AUPNPAT FIELD 3401
N DIR,X,Y
N DIC,ELIG,X,Y
S DIC="^AUPNELM("
S DIC(0)="AEMQ"
S DIC("A")="Select modifier : "
S DIC("S")="I $P(^(0),U,2)=AGELSTS" ;AGELSTS=CURRENT ELIG STATUS
D ^DIC
Q:$D(DTOUT)!($D(DUOUT))
Q:+Y'>0
S ELIG=Y
N DA,DIC,DD,DLAYGO,DO,X,Y
K DD,DO
S X=$P(ELIG,U)
S REC=X
S DINUM=+ELIG
S DA(1)=DFN
S DIC="^AUPNPAT("_DA(1)_",34,"
S DIC(0)="L"
S DIC("P")=$P($G(^DD(9000001,3401,0)),U,2)
S DLAYGO=9000001.03401
D FILE^DICN
K DINUM
D CHKMOD
Q
EDITMOD ;
N DIE,DR,X,Y,DIR,REC
S DIC(0)="AEMQZ"
S DA(1)=DFN
S DIC="^AUPNPAT("_DA(1)_",34,"
D ^DIC S REC=+Y
Q:$D(DTOUT)!($D(DUOUT))!(Y=-1)
S DIE=DIC
S DA=REC
S DR=".01"
D ^DIE
Q:$D(Y) ;USER ENTERED AN "^" NO CHANGE MADE
S ELIG=$P($G(^AUPNELM(REC,0)),U)
D CHKMOD
Q
CHKMOD ;CHECK MOD FOR "MOVED OUT OF CHSDA" OR "DOUBTFUL CASES" TO
;ALLOW UPDATE OF SECONDARY FIELDS
;IF MODIFIER IS "MOVED FROM CHSDA", ENTER DATE FIELD
MD ;
I REC=10&$D(^AUPNPAT(DFN,34,10,0)) D
. S DIE="^AUPNPAT("
. S DA=DFN
. S DR=4901
. D ^DIE
. I $P($G(^AUPNPAT(DFN,49)),U)="" G MD
;IF MODIFIER "MOVED FROM CHSDA" WAS DELETED, DELETE DATE FIELD
I '$D(^AUPNPAT(DFN,34,10,0))&($D(^AUPNPAT(DFN,49))) K ^AUPNPAT(DFN,49)
;IF MODIFIER IS "DOUBTFUL CASES", ENTER # OF VISITS ALLOWED
DC I REC=22&$D(^AUPNPAT(DFN,34,22,0)) D
. S DIE="^AUPNPAT("
. S DA=DFN
. S DR=.26
. D ^DIE
. I $P($G(^AUPNPAT(DFN,0)),U,26)="" G DC
;IF MODIFIER "DOUBTFUL CASES WAS DELETED, DELETE # VISITS ALLOWED
I '$D(^AUPNPAT(DFN,34,22,0))&($P($G(^AUPNPAT(DFN,0)),U,26)'="") S $P(^AUPNPAT(DFN,0),U,26)=""
Q
CHSTAT ;STATUS OF MEDICAL RECORD
N DIC,DIE,DR,DA
S DA(1)=DFN
S DA=DUZ(2)
S DIE="^AUPNPAT("_DA(1)_",41,"
S DR=".04"
D ^DIE
Q
PRIVA ;PRIVACY ACT
N DIC,DIE,DR,DA
S DIE="^AUPNPAT("
S DR=.27
S DA=DFN
D ^DIE
Q
LDOC ;ASK ADD OR EDIT LEGAL DOCS ENTRY
D LDOC^AGLDOC
Q
MCRMSG ;IMPORTANT MESSAGE FORM MEDICARE DATE
I '$D(^AUPNMCR(DFN,0)) W !,"THIS PATIENT HAS NO MEDICARE COVERAGE" H 2
Q:'$D(^AUPNMCR(DFN,0))
N DIC,DIE,DA,DR,DA
S DIE="^AUPNMCR("
S DR="1201;"
S DR(1,9000003)="1201;",DR(2,9000003.1201)=".01"
S DA=DFN
D ^DIE
Q
ROI ;RELEASE OF INFORMATION
N DIC,DIE,DR,DA
S DIE="^AUPNPAT("
S DR="3601;"
S DR(1,9000001)="3601;",DR(2,9000001.03601)=".01"
S DA=DFN
D ^DIE
;
;Force entry if required
I $G(Y)="",$O(^AUPNPAT(DFN,36,"B",""))="",$$RQROI^AGEDERR4(DUZ(2)) W "?? Required" G ROI
Q
AOB ;ASSIGNMENT OF BENEFITS
N DIE,DR,X,Y,DIR,REC,DEF
S DIC(0)="AELMQZ"
S DA(1)=DFN
S DIC="^AUPNPAT("_DA(1)_",71,"
S DEF=$O(^AUPNPAT(DFN,71,"B",""),-1) S:DEF]"" DIC("B")=$$FMTE^DILIBF(DEF,"5U")
D ^DIC S REC=+Y
Q:$D(DTOUT)!($D(DUOUT))
;
;Force entry if required
I $O(^AUPNPAT(DFN,71,"B",""))="",$$RQAOB^AGEDERR4(DUZ(2)) W "?? Required" G AOB
;
Q:Y=-1
;
S DIE=DIC
S DA=REC
S DR=".01"
D ^DIE
Q:$D(Y)
;
;Force entry if last entry deleted during edit
I $O(^AUPNPAT(DFN,71,"B",""))="",$$RQAOB^AGEDERR4(DUZ(2)) G AOB
;
;AG*7.1*8 - Plug AOB into ROI
I AGOPT(25)="Y" D
. N AOB,ROI,AGAOB,DA,ERROR,DIC,X,Y
. ;
. ;Pull ROI - quit if populated
. S ROI=$O(^AUPNPAT(DFN,36,"B",""),-1) Q:ROI]"" ;Pull ROI
. ;
. ;Plug in AOB
. S AOB=$O(^AUPNPAT(DFN,71,"B",""),-1) Q:AOB="" ;Pull AOB
. ;
. S DA(1)=DFN
. S DIC="^AUPNPAT("_DFN_",36,"
. S DIC(0)="L"
. S X=AOB
. D ^DIC
;
Q
NPP ;EP - WAS NPP RECEIVED
N DIC,DIE,DR,DA,DLAYGO
K AG("STAMP")
S DIC="^AUPNNPP("
S DIC(0)="L"
S DLAYGO=9000038
S X="`"_DFN
D ^DIC
Q:$D(DTOUT)!$D(DUOUT)!(Y=-1)
S DIE=DIC
K DIC,DA,DR,X
S DA=+Y
D NOW^%DTC S AG("STAMP")=%
S DR=".02;.03;.06///^S X=AG(""STAMP"");.07////^S X=DUZ"
D ^DIE
I $P($G(^AUPNNPP(DA,0)),U,2)="" W !,"This is a mandatory HIPAA related field and must be answered." H 2 G NPP
Q
ACK ;EP - ACKNOWLEDGEMENT AND REASON
D NPPCHK
I AG("NPPCHK")'=DFN&($D(AG("NPPADD"))) Q
I AG("NPPCHK")'=DFN W !,"Please answer question # 8 first." H 3 G DRAW
N DIC,DIE,DR,DA
S DIE="^AUPNNPP("
S DA=DFN
S DR=.04
D ^DIE
I $P($G(^AUPNNPP(DA,0)),U,4)="" W !,"This is another mandatory HIPAA related field and must be answered." H 2 G ACK
I $P($G(^AUPNNPP(DFN,0)),U,4)="N" D
. S DR=.05
. D ^DIE
I $P($G(^AUPNNPP(DFN,0)),U,4)="Y" D
. S DR=".05///@"
. D ^DIE
K AG("NPPCHK")
Q
NPPCHK ;LOOK FOR EXISTANCE OF AUPNNPP RECORD
K AG("NPPCHK")
S AG("NPPCHK")=$O(^AUPNNPP("B",DFN,""))
Q
RHI ;EP - RESTRICTED HEALTH INFORMATION
D RHICHK^AGED11B
I AG("RHICHK")>0 D EDITRHI^AGED11B Q
I AG("RHICHK")<1 D ADDRHI^AGED11B Q
Q
ADVDIR(DAX) ;DISP ADVANCE DIRECTIVE
K AG("ADVDIR") ;KILL DEFAULT VARIABLE
S DAX=","_DAX_","
D LIST^DIC(9000040.11,DAX,".02;.03;.04",,"*",,,,,,"ADVDIR","ADVDIRER")
I $D(ADVDIRER) K ADVDIRER Q ;CAN'T FIND ENTRY FOR DA PASSED
I $P(ADVDIR("DILIST",0),U)=0 Q ;DID NOT FIND ANY ENTRIES
S ADVLAST=$P(ADVDIR("DILIST",0),U)
W ADVDIR("DILIST","ID",ADVLAST,.02)
W ?40,"DATE: ",ADVDIR("DILIST",1,ADVLAST)
I ADVDIR("DILIST","ID",ADVLAST,.02)="NO" W !?3,"REASON: ",ADVDIR("DILIST","ID",ADVLAST,.04)
E I ADVDIR("DILIST","ID",ADVLAST,.03)'="" W !?3,"TYPE:",ADVDIR("DILIST","ID",ADVLAST,.03)
S AG("ADVDIR")=ADVDIR("DILIST","ID",ADVLAST,.02)
K ADVDIR
Q
ADVDIRED ;ADD/EDIT AN ADVANCE DIRECTIVE
I $D(AG("ADVDIR")) D EDADVDIR ;EDIT EXISTING ENTRY
E D ADADVDIR ;NO ENTRY YET ADD IT
Q
ADADVDIR ;ADD ADVANCE DIRECTIVE
N DIC,DIE,DR,DA
S DIC="^AUPNADVD("
S DIC(0)="L"
S DLAYGO=9000040
S X="`"_DFN
D ^DIC
Q:+Y<0
D EDADVDIR
Q
EDADVDIR ;EDIT EXISTING ADVANCE DIRECTIVE
N DIC,DIE,DR,DA
S DA=DFN
S (DIE,DIC)="^AUPNADVD("
S DR="1101"
;IF ADVANCE DIRECTIVE=NO ASK ONLY REASON
;IF ADVANCE DIRECTIVE=YES ASK ONLY TYPE
S DR(2,9000040.11)=".01;.02;S:X=""N"" Y=""@1"" S:X=""Y"" Y=.03 S:X="""" Y=""@5"";.03;.04///@;S Y=0;@1;.04;.03///@;S Y=0;@5;.03///@;.04///@;.01///@"
D ^DIE
;IF NO ADVANCE DIRECTIVE YES OR NO THEN THERE SHOULD NOT BE A
;REASON OR A TYPE OTHERWISE DELETE THE FIELD NOT NEEDED DEPENDING
;ON IF ITS YES OR NO
;
Q
DRAW ;EP
D CHKRHI^AG
S AG("PG")=9
S ROUTID=$P($T(+1)," ") ;SET ROUTINE ID FOR PROGRAMMER VIEW
D ^AGED
K ^UTILITY("DIQ1",$J)
F AG=1:1 D Q:$G(AGSCRN)[("**END ITEMS**")
. S AGSCRN=$P($T(@1+AG),";;",2,13)
. Q:AGSCRN[("**END ITEMS**")
. S AGNEWLN=$P(AGSCRN,U,5)
. I AG'=1 D
.. I AGNEWLN'="" W @AGNEWLN,AG,".",?$P(AGSCRN,U,2),$P(AGSCRN,U)," : "
.. E W ?$P(AGSCRN,U,2),AG,".",$P(AGSCRN,U)," : "
. ;I AG'=1&(AG'=2) D
. I AG'=1&(AG'=2)&(AG'=3) D ;AG*7.1*1 IM18991
.. S DA=DFN
.. S DIC=$P(AGSCRN,U,3)
.. S DR=$P(AGSCRN,U,4)
.. Q:'DIC!('DR) ;DISP ADDED TO CHECK FOR FILLER ITEMS IN TAG 1
.. ;SHOW LAST AOB
.. ;I AG=7 D
.. I AG=6 D
... S AG("AOB")=$O(^AUPNPAT(DFN,71,"B",""),-1)
... I $G(AG("AOB"))'="" W $E(AG("AOB"),4,5)_"/"_$E(AG("AOB"),6,7)_"/"_($E(AG("AOB"),1,3)+1700)
.. K AGRES
.. S TEMPDIC=DIC
.. S DIQ="AGRES",DIQ(0)="E" D EN^DIQ1
.. S DIC=TEMPDIC
.. W $G(AGRES(DIC,DA,DR,"E"))
.. K AGRES,TEMPDIC,AGRES
. I AG=1 D
.. W !,AG,".",?2,"REASON FOR "_$S(AGELSTS="C":"CHS & DIRECT",AGELSTS="I":"INELIGIBLE",AGELSTS="D":"DIRECT ONLY",AGELSTS="P":"PENDING",1:"NONE")_" : "
.. S (D1,CNT)=0,MOD="",MOVDT="",NUMCASES=""
.. F S D1=$O(^AUPNPAT(DFN,34,D1)) Q:'D1 D
... S MOD=$P($G(^AUPNELM(D1,0)),U)
... I MOD["MOVED OUT OF CHSDA" D
.... S MOVDT=$P($G(^AUPNPAT(DFN,49)),U)
.... I MOVDT="" S Y=""
.... E S Y=$E(MOVDT,4,5)_"/"_$E(MOVDT,6,7)_"/"_($E(MOVDT,1,3)+1700)
... I MOD["DOUBTFUL CASES" D
.... S NUMCASES=$P($G(^AUPNPAT(DFN,0)),U,26)
... W ?29,$E(MOD,1,45)
... I MOD["MOVED OUT OF CHSDA" W ?51,"DATE MOVED : ",Y
... I MOD["DOUBTFUL CASES" W ?63,"# VISITS : ",NUMCASES
... S CNT=CNT+1
... I CNT<$P($G(^AUPNPAT(DFN,34,0)),U,4) W !
. I AG=2 D
.. S DA(1)=DFN
.. S DA=DUZ(2)
.. S DIC="^AUPNPAT("_DA(1)_",41,"
.. I AG=2 S DR=".04"
.. K AGRES
.. S TEMPDIC=DIC
.. S DIQ="AGRES",DIQ(0)="E" D EN^DIQ1
.. S DIC=TEMPDIC
.. W $G(AGRES(9000001.41,DA,DR,"E"))
.. K AGRES,TEMPDIC,AGRES
. ;I AG=4 D
. I AG=3 D
.. S D1=0 K DOCSTR,DOCPTR,DOC
.. F S D1=$O(^AUPNPLDC("C",DFN,D1)) Q:'D1 D
... S DOCSTR=$G(^AUPNPLDC(D1,0))
... S DOCPTR=$P(DOCSTR,U,3)
... I DOCPTR'="",$D(^AUPNELM(DOCPTR,0)) S DOC=$P($G(^AUPNELM(DOCPTR,0)),U)
.. I $D(DOC) W DOC
. ;I AG=5 D ADVDIR(DFN)
. I AG=4 D ADVDIR(DFN)
. ;I AG=6 D
. I AG=5 D
.. S AG("ROI")=$O(^AUPNPAT(DFN,36,"B",""),-1)
.. I $G(AG("ROI"))'="" W $E(AG("ROI"),4,5)_"/"_$E(AG("ROI"),6,7)_"/"_($E(AG("ROI"),1,3)+1700)
. ;I AG=1!(AG=4)!(AG=5)!(AG=7) W !,AGLINE("-")
. I AG=1!(AG=4)!(AG=6) W !,AGLINE("-")
. ;I AG=8&($D(^AUPNNPP(DFN,0))) D
. I AG=7&($D(^AUPNNPP(DFN,0))) D
.. S NPPDT=$P($G(^AUPNNPP(DFN,0)),U,3)
.. Q:NPPDT=""
.. S Y=$E(NPPDT,4,5)_"/"_$E(NPPDT,6,7)_"/"_($E(NPPDT,1,3)+1700)
.. W ?63,"DATE:",Y
. ;I AG=9&($P($G(^AUPNNPP(DFN,0)),U,5)'="") D
. I AG=8&($P($G(^AUPNNPP(DFN,0)),U,5)'="") D
.. W !,?5,"REASON: ",$P($G(^AUPNNPP(DFN,0)),U,5)
. ;I AG=10 D FINDRHI^AGED11B
. I AG=9 D FINDRHI^AGED11B
S AG("N")=AG-1
W !,AGLINE("EQ")
K MYERRS,MYVARS
D FETCHERR^AGEDERR(AG("PG"),.MYERRS)
S MYVARS("DFN")=DFN,MYVARS("FINDCALL")="",MYVARS("SITE")=DUZ(2)
D EDITCHEK^AGEDERR(.MYERRS,.MYVARS,1)
W !,$G(AGLINE("-"))
D VERIF^AGUTILS
Q
;FORMAT OF LINES BELOW
;ITEM CAPTION^INDENT^FILE #/SUB FILE#^FIELD #^NEW LINE?
;DATE PRIVACY ACT OBTAINED^3^9000001^.27^! ;AG*7.1* REMOVED PER Cancellation of IHS 819 & 820
1 ;
;;REASON FOR^1^9000001.34^.01^!
;;STATUS OF MEDICAL RECORD^3^9000001.41^.04^!
;;OTHER LEGAL DOCUMENTS^3^9000034^.03^!
;;ADVANCE DIRECTIVES^3^^^!
;;REL OF INFORMATION^3^9000001.03601^.01^
;;ASSIGNMENT OF BENEFITS^40^9000001^7101^^
;;NOTICE OF PRIVACY PRACTICES (NPP) REC'D BY PATIENT^1^9000038^.02^!
;;ACKNOWLEDGEMENT OF RECEIPT OF NPP SIGNED^1^9000038^.04^!
;;RESTRICTED HEALTH INFORMATION^1^9000039^.03^!
;;**END ITEMS**
AGED11A ; IHS/ASDS/EFG - EDIT DOCUMENT SUMMARY PAGE (PAGE 9) ; MAR 19, 2010
+1 ;;7.1;PATIENT REGISTRATION;**1,2,7,8**;AUG 25, 2005
+2 ;
+3 ;AG*7.1*7 - Modified code to allow the new page 10 to be called
+4 ;
VAR DO DRAW
+1 IF $DATA(AGSEENLY)
QUIT
+2 KILL DIR
+3 SET DIR("?")="Enter your choice now."
+4 SET DIR("?",1)="You may enter the item number of the field you wish to edit,"
+5 SET DIR("?",2)="OR you can enter 'P#' where P stands for 'page' and '#' stands for"
+6 SET DIR("?",3)="the page you wish to jump to, OR enter '^' to go back one page"
+7 SET DIR("?",4)="OR, enter '^^' to exit the edit screens, OR RETURN to go back to the main menu."
+8 SET DIR("A")="CHANGE which item? (1-"_AG("N")_") NONE// "
+9 DO READ^AGED1
+10 IF $DATA(MYERRS("C","E"))
IF (Y'?1N.N)
IF (Y'=AGOPT("ESCAPE"))
WRITE !,"ERRORS ON THIS PAGE. PLEASE FIX BEFORE EXITING!!"
HANG 3
GOTO VAR
+11 IF Y=AGOPT("ESCAPE")
QUIT
+12 IF $DATA(DTOUT)!$DATA(DFOUT)
QUIT
+13 IF $DATA(DUOUT)&'$DATA(AGXTERN)
GOTO ^AGED11
IF $DATA(AG("ERR"))
GOTO VAR
IF $DATA(DLOUT)!(Y["N")
GOTO END
IF $DATA(AG("ED"))&'$DATA(AGXTERN)
GOTO @("^AGED"_AG("ED"))
+14 IF $DATA(DQOUT)!(+Y<1)!(+Y>AG("N"))
WRITE !!,"You must enter a number from 1 to ",AG("N")
HANG 2
GOTO VAR
+15 WRITE !!
CC ;S AG("C")="EMOD,CHSTAT,PRIVA,LDOC,ADVDIRED,ROI,AOB,NPP,ACK,RHI"
+1 SET AG("C")="EMOD,CHSTAT,LDOC,ADVDIRED,ROI,AOB,NPP,ACK,RHI"
C ;EP - Edit multiple fields on a Reg edit page.
+1 SET AGY=Y
FOR AGI=1:1
SET AG("SEL")=+$PIECE(AGY,",",AGI)
IF AG("SEL")<1!(AG("SEL")>AG("N"))
QUIT
DO @($PIECE(AG("C"),",",AG("SEL")))
+2 DO UPDATE1^AGED(DUZ(2),DFN,8,"")
KILL AGI,AGY
+3 GOTO VAR
END KILL AG,DFOUT,DQOUT,DTOUT,DA,DIC,DIE,DR,AGSCRN,Y,NUMCASES,CNT,MOD,MOVDT
+1 KILL ROUTID
+2 IF $DATA(AGXTERN)
QUIT
+3 IF $DATA(DIROUT)
QUIT
+4 IF $DATA(AGSEENLY)
QUIT
+5 GOTO ^AGED10A
EMOD ;LOOKUP FOR ELIGIBILITY MODIFIER FIELD
+1 NEW DIC,DA,X,Y,DIR
+2 KILL DTOUT,DUOUT
+3 SET DIR(0)="F"
+4 IF $ORDER(^AUPNPAT(DFN,34,0))
SET DIR("A")="Do you wish to E(dit) or A(dd) an Eligibility Modifier ? "
+5 IF '$TEST
SET DIR("A")="Do you wish to A(dd) an Eligibility Modifier ? "
+6 DO ^DIR
+7 IF $DATA(DTOUT)!(Y="^")
QUIT
+8 IF Y'="E"&(Y'="A")
GOTO EMOD
+9 IF Y="A"
DO ADDMOD
QUIT
+10 IF Y="E"
IF $ORDER(^AUPNPAT(DFN,34,0))
DO EDITMOD
QUIT
+11 QUIT
ADDMOD ;ADD A NEW MODIFIER TO AUPNPAT FIELD 3401
+1 NEW DIR,X,Y
+2 NEW DIC,ELIG,X,Y
+3 SET DIC="^AUPNELM("
+4 SET DIC(0)="AEMQ"
+5 SET DIC("A")="Select modifier : "
+6 ;AGELSTS=CURRENT ELIG STATUS
SET DIC("S")="I $P(^(0),U,2)=AGELSTS"
+7 DO ^DIC
+8 IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+9 IF +Y'>0
QUIT
+10 SET ELIG=Y
+11 NEW DA,DIC,DD,DLAYGO,DO,X,Y
+12 KILL DD,DO
+13 SET X=$PIECE(ELIG,U)
+14 SET REC=X
+15 SET DINUM=+ELIG
+16 SET DA(1)=DFN
+17 SET DIC="^AUPNPAT("_DA(1)_",34,"
+18 SET DIC(0)="L"
+19 SET DIC("P")=$PIECE($GET(^DD(9000001,3401,0)),U,2)
+20 SET DLAYGO=9000001.03401
+21 DO FILE^DICN
+22 KILL DINUM
+23 DO CHKMOD
+24 QUIT
EDITMOD ;
+1 NEW DIE,DR,X,Y,DIR,REC
+2 SET DIC(0)="AEMQZ"
+3 SET DA(1)=DFN
+4 SET DIC="^AUPNPAT("_DA(1)_",34,"
+5 DO ^DIC
SET REC=+Y
+6 IF $DATA(DTOUT)!($DATA(DUOUT))!(Y=-1)
QUIT
+7 SET DIE=DIC
+8 SET DA=REC
+9 SET DR=".01"
+10 DO ^DIE
+11 ;USER ENTERED AN "^" NO CHANGE MADE
IF $DATA(Y)
QUIT
+12 SET ELIG=$PIECE($GET(^AUPNELM(REC,0)),U)
+13 DO CHKMOD
+14 QUIT
CHKMOD ;CHECK MOD FOR "MOVED OUT OF CHSDA" OR "DOUBTFUL CASES" TO
+1 ;ALLOW UPDATE OF SECONDARY FIELDS
+2 ;IF MODIFIER IS "MOVED FROM CHSDA", ENTER DATE FIELD
MD ;
+1 IF REC=10&$DATA(^AUPNPAT(DFN,34,10,0))
Begin DoDot:1
+2 SET DIE="^AUPNPAT("
+3 SET DA=DFN
+4 SET DR=4901
+5 DO ^DIE
+6 IF $PIECE($GET(^AUPNPAT(DFN,49)),U)=""
GOTO MD
End DoDot:1
+7 ;IF MODIFIER "MOVED FROM CHSDA" WAS DELETED, DELETE DATE FIELD
+8 IF '$DATA(^AUPNPAT(DFN,34,10,0))&($DATA(^AUPNPAT(DFN,49)))
KILL ^AUPNPAT(DFN,49)
+9 ;IF MODIFIER IS "DOUBTFUL CASES", ENTER # OF VISITS ALLOWED
DC IF REC=22&$DATA(^AUPNPAT(DFN,34,22,0))
Begin DoDot:1
+1 SET DIE="^AUPNPAT("
+2 SET DA=DFN
+3 SET DR=.26
+4 DO ^DIE
+5 IF $PIECE($GET(^AUPNPAT(DFN,0)),U,26)=""
GOTO DC
End DoDot:1
+6 ;IF MODIFIER "DOUBTFUL CASES WAS DELETED, DELETE # VISITS ALLOWED
+7 IF '$DATA(^AUPNPAT(DFN,34,22,0))&($PIECE($GET(^AUPNPAT(DFN,0)),U,26)'="")
SET $PIECE(^AUPNPAT(DFN,0),U,26)=""
+8 QUIT
CHSTAT ;STATUS OF MEDICAL RECORD
+1 NEW DIC,DIE,DR,DA
+2 SET DA(1)=DFN
+3 SET DA=DUZ(2)
+4 SET DIE="^AUPNPAT("_DA(1)_",41,"
+5 SET DR=".04"
+6 DO ^DIE
+7 QUIT
PRIVA ;PRIVACY ACT
+1 NEW DIC,DIE,DR,DA
+2 SET DIE="^AUPNPAT("
+3 SET DR=.27
+4 SET DA=DFN
+5 DO ^DIE
+6 QUIT
LDOC ;ASK ADD OR EDIT LEGAL DOCS ENTRY
+1 DO LDOC^AGLDOC
+2 QUIT
MCRMSG ;IMPORTANT MESSAGE FORM MEDICARE DATE
+1 IF '$DATA(^AUPNMCR(DFN,0))
WRITE !,"THIS PATIENT HAS NO MEDICARE COVERAGE"
HANG 2
+2 IF '$DATA(^AUPNMCR(DFN,0))
QUIT
+3 NEW DIC,DIE,DA,DR,DA
+4 SET DIE="^AUPNMCR("
+5 SET DR="1201;"
+6 SET DR(1,9000003)="1201;"
SET DR(2,9000003.1201)=".01"
+7 SET DA=DFN
+8 DO ^DIE
+9 QUIT
ROI ;RELEASE OF INFORMATION
+1 NEW DIC,DIE,DR,DA
+2 SET DIE="^AUPNPAT("
+3 SET DR="3601;"
+4 SET DR(1,9000001)="3601;"
SET DR(2,9000001.03601)=".01"
+5 SET DA=DFN
+6 DO ^DIE
+7 ;
+8 ;Force entry if required
+9 IF $GET(Y)=""
IF $ORDER(^AUPNPAT(DFN,36,"B",""))=""
IF $$RQROI^AGEDERR4(DUZ(2))
WRITE "?? Required"
GOTO ROI
+10 QUIT
AOB ;ASSIGNMENT OF BENEFITS
+1 NEW DIE,DR,X,Y,DIR,REC,DEF
+2 SET DIC(0)="AELMQZ"
+3 SET DA(1)=DFN
+4 SET DIC="^AUPNPAT("_DA(1)_",71,"
+5 SET DEF=$ORDER(^AUPNPAT(DFN,71,"B",""),-1)
IF DEF]""
SET DIC("B")=$$FMTE^DILIBF(DEF,"5U")
+6 DO ^DIC
SET REC=+Y
+7 IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+8 ;
+9 ;Force entry if required
+10 IF $ORDER(^AUPNPAT(DFN,71,"B",""))=""
IF $$RQAOB^AGEDERR4(DUZ(2))
WRITE "?? Required"
GOTO AOB
+11 ;
+12 IF Y=-1
QUIT
+13 ;
+14 SET DIE=DIC
+15 SET DA=REC
+16 SET DR=".01"
+17 DO ^DIE
+18 IF $DATA(Y)
QUIT
+19 ;
+20 ;Force entry if last entry deleted during edit
+21 IF $ORDER(^AUPNPAT(DFN,71,"B",""))=""
IF $$RQAOB^AGEDERR4(DUZ(2))
GOTO AOB
+22 ;
+23 ;AG*7.1*8 - Plug AOB into ROI
+24 IF AGOPT(25)="Y"
Begin DoDot:1
+25 NEW AOB,ROI,AGAOB,DA,ERROR,DIC,X,Y
+26 ;
+27 ;Pull ROI - quit if populated
+28 ;Pull ROI
SET ROI=$ORDER(^AUPNPAT(DFN,36,"B",""),-1)
IF ROI]""
QUIT
+29 ;
+30 ;Plug in AOB
+31 ;Pull AOB
SET AOB=$ORDER(^AUPNPAT(DFN,71,"B",""),-1)
IF AOB=""
QUIT
+32 ;
+33 SET DA(1)=DFN
+34 SET DIC="^AUPNPAT("_DFN_",36,"
+35 SET DIC(0)="L"
+36 SET X=AOB
+37 DO ^DIC
End DoDot:1
+38 ;
+39 QUIT
NPP ;EP - WAS NPP RECEIVED
+1 NEW DIC,DIE,DR,DA,DLAYGO
+2 KILL AG("STAMP")
+3 SET DIC="^AUPNNPP("
+4 SET DIC(0)="L"
+5 SET DLAYGO=9000038
+6 SET X="`"_DFN
+7 DO ^DIC
+8 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y=-1)
QUIT
+9 SET DIE=DIC
+10 KILL DIC,DA,DR,X
+11 SET DA=+Y
+12 DO NOW^%DTC
SET AG("STAMP")=%
+13 SET DR=".02;.03;.06///^S X=AG(""STAMP"");.07////^S X=DUZ"
+14 DO ^DIE
+15 IF $PIECE($GET(^AUPNNPP(DA,0)),U,2)=""
WRITE !,"This is a mandatory HIPAA related field and must be answered."
HANG 2
GOTO NPP
+16 QUIT
ACK ;EP - ACKNOWLEDGEMENT AND REASON
+1 DO NPPCHK
+2 IF AG("NPPCHK")'=DFN&($DATA(AG("NPPADD")))
QUIT
+3 IF AG("NPPCHK")'=DFN
WRITE !,"Please answer question # 8 first."
HANG 3
GOTO DRAW
+4 NEW DIC,DIE,DR,DA
+5 SET DIE="^AUPNNPP("
+6 SET DA=DFN
+7 SET DR=.04
+8 DO ^DIE
+9 IF $PIECE($GET(^AUPNNPP(DA,0)),U,4)=""
WRITE !,"This is another mandatory HIPAA related field and must be answered."
HANG 2
GOTO ACK
+10 IF $PIECE($GET(^AUPNNPP(DFN,0)),U,4)="N"
Begin DoDot:1
+11 SET DR=.05
+12 DO ^DIE
End DoDot:1
+13 IF $PIECE($GET(^AUPNNPP(DFN,0)),U,4)="Y"
Begin DoDot:1
+14 SET DR=".05///@"
+15 DO ^DIE
End DoDot:1
+16 KILL AG("NPPCHK")
+17 QUIT
NPPCHK ;LOOK FOR EXISTANCE OF AUPNNPP RECORD
+1 KILL AG("NPPCHK")
+2 SET AG("NPPCHK")=$ORDER(^AUPNNPP("B",DFN,""))
+3 QUIT
RHI ;EP - RESTRICTED HEALTH INFORMATION
+1 DO RHICHK^AGED11B
+2 IF AG("RHICHK")>0
DO EDITRHI^AGED11B
QUIT
+3 IF AG("RHICHK")<1
DO ADDRHI^AGED11B
QUIT
+4 QUIT
ADVDIR(DAX) ;DISP ADVANCE DIRECTIVE
+1 ;KILL DEFAULT VARIABLE
KILL AG("ADVDIR")
+2 SET DAX=","_DAX_","
+3 DO LIST^DIC(9000040.11,DAX,".02;.03;.04",,"*",,,,,,"ADVDIR","ADVDIRER")
+4 ;CAN'T FIND ENTRY FOR DA PASSED
IF $DATA(ADVDIRER)
KILL ADVDIRER
QUIT
+5 ;DID NOT FIND ANY ENTRIES
IF $PIECE(ADVDIR("DILIST",0),U)=0
QUIT
+6 SET ADVLAST=$PIECE(ADVDIR("DILIST",0),U)
+7 WRITE ADVDIR("DILIST","ID",ADVLAST,.02)
+8 WRITE ?40,"DATE: ",ADVDIR("DILIST",1,ADVLAST)
+9 IF ADVDIR("DILIST","ID",ADVLAST,.02)="NO"
WRITE !?3,"REASON: ",ADVDIR("DILIST","ID",ADVLAST,.04)
+10 IF '$TEST
IF ADVDIR("DILIST","ID",ADVLAST,.03)'=""
WRITE !?3,"TYPE:",ADVDIR("DILIST","ID",ADVLAST,.03)
+11 SET AG("ADVDIR")=ADVDIR("DILIST","ID",ADVLAST,.02)
+12 KILL ADVDIR
+13 QUIT
ADVDIRED ;ADD/EDIT AN ADVANCE DIRECTIVE
+1 ;EDIT EXISTING ENTRY
IF $DATA(AG("ADVDIR"))
DO EDADVDIR
+2 ;NO ENTRY YET ADD IT
IF '$TEST
DO ADADVDIR
+3 QUIT
ADADVDIR ;ADD ADVANCE DIRECTIVE
+1 NEW DIC,DIE,DR,DA
+2 SET DIC="^AUPNADVD("
+3 SET DIC(0)="L"
+4 SET DLAYGO=9000040
+5 SET X="`"_DFN
+6 DO ^DIC
+7 IF +Y<0
QUIT
+8 DO EDADVDIR
+9 QUIT
EDADVDIR ;EDIT EXISTING ADVANCE DIRECTIVE
+1 NEW DIC,DIE,DR,DA
+2 SET DA=DFN
+3 SET (DIE,DIC)="^AUPNADVD("
+4 SET DR="1101"
+5 ;IF ADVANCE DIRECTIVE=NO ASK ONLY REASON
+6 ;IF ADVANCE DIRECTIVE=YES ASK ONLY TYPE
+7 SET DR(2,9000040.11)=".01;.02;S:X=""N"" Y=""@1"" S:X=""Y"" Y=.03 S:X="""" Y=""@5"";.03;.04///@;S Y=0;@1;.04;.03///@;S Y=0;@5;.03///@;.04///@;.01///@"
+8 DO ^DIE
+9 ;IF NO ADVANCE DIRECTIVE YES OR NO THEN THERE SHOULD NOT BE A
+10 ;REASON OR A TYPE OTHERWISE DELETE THE FIELD NOT NEEDED DEPENDING
+11 ;ON IF ITS YES OR NO
+12 ;
+13 QUIT
DRAW ;EP
+1 DO CHKRHI^AG
+2 SET AG("PG")=9
+3 ;SET ROUTINE ID FOR PROGRAMMER VIEW
SET ROUTID=$PIECE($TEXT(+1)," ")
+4 DO ^AGED
+5 KILL ^UTILITY("DIQ1",$JOB)
+6 FOR AG=1:1
Begin DoDot:1
+7 SET AGSCRN=$PIECE($TEXT(@1+AG),";;",2,13)
+8 IF AGSCRN[("**END ITEMS**")
QUIT
+9 SET AGNEWLN=$PIECE(AGSCRN,U,5)
+10 IF AG'=1
Begin DoDot:2
+11 IF AGNEWLN'=""
WRITE @AGNEWLN,AG,".",?$PIECE(AGSCRN,U,2),$PIECE(AGSCRN,U)," : "
+12 IF '$TEST
WRITE ?$PIECE(AGSCRN,U,2),AG,".",$PIECE(AGSCRN,U)," : "
End DoDot:2
+13 ;I AG'=1&(AG'=2) D
+14 ;AG*7.1*1 IM18991
IF AG'=1&(AG'=2)&(AG'=3)
Begin DoDot:2
+15 SET DA=DFN
+16 SET DIC=$PIECE(AGSCRN,U,3)
+17 SET DR=$PIECE(AGSCRN,U,4)
+18 ;DISP ADDED TO CHECK FOR FILLER ITEMS IN TAG 1
IF 'DIC!('DR)
QUIT
+19 ;SHOW LAST AOB
+20 ;I AG=7 D
+21 IF AG=6
Begin DoDot:3
+22 SET AG("AOB")=$ORDER(^AUPNPAT(DFN,71,"B",""),-1)
+23 IF $GET(AG("AOB"))'=""
WRITE $EXTRACT(AG("AOB"),4,5)_"/"_$EXTRACT(AG("AOB"),6,7)_"/"_($EXTRACT(AG("AOB"),1,3)+1700)
End DoDot:3
+24 KILL AGRES
+25 SET TEMPDIC=DIC
+26 SET DIQ="AGRES"
SET DIQ(0)="E"
DO EN^DIQ1
+27 SET DIC=TEMPDIC
+28 WRITE $GET(AGRES(DIC,DA,DR,"E"))
+29 KILL AGRES,TEMPDIC,AGRES
End DoDot:2
+30 IF AG=1
Begin DoDot:2
+31 WRITE !,AG,".",?2,"REASON FOR "_$SELECT(AGELSTS="C":"CHS & DIRECT",AGELSTS="I":"INELIGIBLE",AGELSTS="D":"DIRECT ONLY",AGELSTS="P":"PENDING",1:"NONE")_" : "
+32 SET (D1,CNT)=0
SET MOD=""
SET MOVDT=""
SET NUMCASES=""
+33 FOR
SET D1=$ORDER(^AUPNPAT(DFN,34,D1))
IF 'D1
QUIT
Begin DoDot:3
+34 SET MOD=$PIECE($GET(^AUPNELM(D1,0)),U)
+35 IF MOD["MOVED OUT OF CHSDA"
Begin DoDot:4
+36 SET MOVDT=$PIECE($GET(^AUPNPAT(DFN,49)),U)
+37 IF MOVDT=""
SET Y=""
+38 IF '$TEST
SET Y=$EXTRACT(MOVDT,4,5)_"/"_$EXTRACT(MOVDT,6,7)_"/"_($EXTRACT(MOVDT,1,3)+1700)
End DoDot:4
+39 IF MOD["DOUBTFUL CASES"
Begin DoDot:4
+40 SET NUMCASES=$PIECE($GET(^AUPNPAT(DFN,0)),U,26)
End DoDot:4
+41 WRITE ?29,$EXTRACT(MOD,1,45)
+42 IF MOD["MOVED OUT OF CHSDA"
WRITE ?51,"DATE MOVED : ",Y
+43 IF MOD["DOUBTFUL CASES"
WRITE ?63,"# VISITS : ",NUMCASES
+44 SET CNT=CNT+1
+45 IF CNT<$PIECE($GET(^AUPNPAT(DFN,34,0)),U,4)
WRITE !
End DoDot:3
End DoDot:2
+46 IF AG=2
Begin DoDot:2
+47 SET DA(1)=DFN
+48 SET DA=DUZ(2)
+49 SET DIC="^AUPNPAT("_DA(1)_",41,"
+50 IF AG=2
SET DR=".04"
+51 KILL AGRES
+52 SET TEMPDIC=DIC
+53 SET DIQ="AGRES"
SET DIQ(0)="E"
DO EN^DIQ1
+54 SET DIC=TEMPDIC
+55 WRITE $GET(AGRES(9000001.41,DA,DR,"E"))
+56 KILL AGRES,TEMPDIC,AGRES
End DoDot:2
+57 ;I AG=4 D
+58 IF AG=3
Begin DoDot:2
+59 SET D1=0
KILL DOCSTR,DOCPTR,DOC
+60 FOR
SET D1=$ORDER(^AUPNPLDC("C",DFN,D1))
IF 'D1
QUIT
Begin DoDot:3
+61 SET DOCSTR=$GET(^AUPNPLDC(D1,0))
+62 SET DOCPTR=$PIECE(DOCSTR,U,3)
+63 IF DOCPTR'=""
IF $DATA(^AUPNELM(DOCPTR,0))
SET DOC=$PIECE($GET(^AUPNELM(DOCPTR,0)),U)
End DoDot:3
+64 IF $DATA(DOC)
WRITE DOC
End DoDot:2
+65 ;I AG=5 D ADVDIR(DFN)
+66 IF AG=4
DO ADVDIR(DFN)
+67 ;I AG=6 D
+68 IF AG=5
Begin DoDot:2
+69 SET AG("ROI")=$ORDER(^AUPNPAT(DFN,36,"B",""),-1)
+70 IF $GET(AG("ROI"))'=""
WRITE $EXTRACT(AG("ROI"),4,5)_"/"_$EXTRACT(AG("ROI"),6,7)_"/"_($EXTRACT(AG("ROI"),1,3)+1700)
End DoDot:2
+71 ;I AG=1!(AG=4)!(AG=5)!(AG=7) W !,AGLINE("-")
+72 IF AG=1!(AG=4)!(AG=6)
WRITE !,AGLINE("-")
+73 ;I AG=8&($D(^AUPNNPP(DFN,0))) D
+74 IF AG=7&($DATA(^AUPNNPP(DFN,0)))
Begin DoDot:2
+75 SET NPPDT=$PIECE($GET(^AUPNNPP(DFN,0)),U,3)
+76 IF NPPDT=""
QUIT
+77 SET Y=$EXTRACT(NPPDT,4,5)_"/"_$EXTRACT(NPPDT,6,7)_"/"_($EXTRACT(NPPDT,1,3)+1700)
+78 WRITE ?63,"DATE:",Y
End DoDot:2
+79 ;I AG=9&($P($G(^AUPNNPP(DFN,0)),U,5)'="") D
+80 IF AG=8&($PIECE($GET(^AUPNNPP(DFN,0)),U,5)'="")
Begin DoDot:2
+81 WRITE !,?5,"REASON: ",$PIECE($GET(^AUPNNPP(DFN,0)),U,5)
End DoDot:2
+82 ;I AG=10 D FINDRHI^AGED11B
+83 IF AG=9
DO FINDRHI^AGED11B
End DoDot:1
IF $GET(AGSCRN)[("**END ITEMS**")
QUIT
+84 SET AG("N")=AG-1
+85 WRITE !,AGLINE("EQ")
+86 KILL MYERRS,MYVARS
+87 DO FETCHERR^AGEDERR(AG("PG"),.MYERRS)
+88 SET MYVARS("DFN")=DFN
SET MYVARS("FINDCALL")=""
SET MYVARS("SITE")=DUZ(2)
+89 DO EDITCHEK^AGEDERR(.MYERRS,.MYVARS,1)
+90 WRITE !,$GET(AGLINE("-"))
+91 DO VERIF^AGUTILS
+92 QUIT
+93 ;FORMAT OF LINES BELOW
+94 ;ITEM CAPTION^INDENT^FILE #/SUB FILE#^FIELD #^NEW LINE?
+95 ;DATE PRIVACY ACT OBTAINED^3^9000001^.27^! ;AG*7.1* REMOVED PER Cancellation of IHS 819 & 820
1 ;
+1 ;;REASON FOR^1^9000001.34^.01^!
+2 ;;STATUS OF MEDICAL RECORD^3^9000001.41^.04^!
+3 ;;OTHER LEGAL DOCUMENTS^3^9000034^.03^!
+4 ;;ADVANCE DIRECTIVES^3^^^!
+5 ;;REL OF INFORMATION^3^9000001.03601^.01^
+6 ;;ASSIGNMENT OF BENEFITS^40^9000001^7101^^
+7 ;;NOTICE OF PRIVACY PRACTICES (NPP) REC'D BY PATIENT^1^9000038^.02^!
+8 ;;ACKNOWLEDGEMENT OF RECEIPT OF NPP SIGNED^1^9000038^.04^!
+9 ;;RESTRICTED HEALTH INFORMATION^1^9000039^.03^!
+10 ;;**END ITEMS**
