AGFACE ; IHS/ASDS/EFG - FACE SHEET ; MAR 19, 2010
;;7.1;PATIENT REGISTRATION;**1,2,4,5,7,9,11**;AUG 25, 2005;Build 1
;IHS/OIT/NKD AG*7.1*11 MU2 MULTIPLE RACES
;IHS/OIT/NKD AG*7.1*11 MU2 PREFERRED METHOD
;
NODFN ;EP - No Pre-Defined Patient Number.
D PTLK^AG
Q:'$D(DFN)
G L1
DFN ;PEP - Pre-Defined Patient Number.
Q:'$D(DFN)
D CHKRHI^AG
I $D(RHIFLAG)&(RHIFLAG="A") W !,$$S^AGVDF("RVN"),$$S^AGVDF("BLN"),"This patient has Restricted Health Information",$$S^AGVDF("BLF"),$$S^AGVDF("RVF")
L1 K AG Q:'$D(DFN) D ^AGDATCK I AG("DTOT")>0 D ^AGBADATA
I AGOPT(24)="Y" D PRINTVS
DEV ;
;S XBNS="AG;DFN",XBRP="START^AGFACE" D ^XBDBQUE
;IM22794 ERROR DURING ALPHA TESTING. NOT REPORTED BY SITE
S %ZIS="QA"
D ^%ZIS
G:POP NODFN
I $G(IO("Q")) D QUE D HOME^%ZIS Q
U IO
D START
D ^%ZISC
D HOME^%ZIS
Q
START ;PEP - From TaskMan.
Q:'$G(DFN) ;IHS/SD/TPF AG*7.1*1 REPORTED BY FDIH CALL FROM CIA REMOTE
;PROCEDURE HAD DFN=0 IM18987
Q:'$G(DUZ(2))
D ^AGVAR,LINES^AG,NOW^AG S AG("LOC")=$P($G(^DIC(4,DUZ(2),0)),U)
S AG("PAGE")=0 D HDR
S DIC=9000001,DR=.02 D ^AGDICLK W "COMPUTER FILE EST: " W:$D(AG("LKPRINT")) AG("LKPRINT") S AG=$P($G(^AUPNPAT(DFN,0)),U,11) I AG,$D(^VA(200,AG,0)) W "(",$P(^(0),U,2),")"
S DR=.03,AGLAST="LAST EDIT: " D ^AGDICLK
S:$D(AG("LKPRINT")) AGLAST=AGLAST_AG("LKPRINT") S AG=$P($G(^AUPNPAT(DFN,0)),U,12) I AG,$D(^VA(200,AG,0)) S AGLAST=AGLAST_" ("_$P(^(0),U,2)_")"
W ?78-$L(AGLAST),AGLAST,!,AG("-")
ALIAS ;OTHER NAMES
I $O(^DPT(DFN,.01,0)) D
.W !,"OTHER NAME(S):"
.N I S I=0 F S I=$O(^DPT(DFN,.01,I)) Q:'I D
..W ?16,$P(^DPT(DFN,.01,I,0),"^",1),!
E W !
S DR=.09,DIC=2 D ^AGDICLK
;I $D(AG("LKPRINT")) W "SSN: ",AG("LKPRINT") D
;I $$GET1^DIQ(2,DFN_",",1107.3)'="" W "SSN: ",$$GET1^DIQ(9000001,DFN_",",1107.3) D ;IHS/SD/TPF AG*7.1*4
I $$GET1^DIQ(9000001,DFN_",",1107.3)'="" W "SSN: ",$$GET1^DIQ(9000001,DFN_",",1107.3) D ;IHS/SD/TPF AG*7.1*5
.I $P(^AUPNPAT(DA,0),U,23) W ?40,"SSN STATUS: ",$P(^AUTTSSN($P(^(0),U,23),0),U,2)
.E W ?40,"SSN STATUS UNKNOWN"
W !,"CLASS: " S DR=1111,DIC=9000001 D ^AGDICLK W:$D(AG("LKPRINT")) AG("LKPRINT")
W ?62,"SEX: " S DR=.02,DIC=2 D ^AGDICLK W:$D(AG("LKPRINT")) AG("LKPRINT")
W !,"COMMUNITY: " S DR=1118,DIC=9000001 D ^AGDICLK W:$D(AG("LKPRINT")) AG("LKPRINT") I AGOPT(14)="Y",$D(^AUPNPAT(DFN,11)) W " (",$S($P(^(11),U,21)="Y":"Verified",1:"Unverified"),")"
W ?57,"BIRTHDAY: " S DR=.03,DIC=2 D ^AGDICLK W:$D(AG("LKPRINT")) AG("LKPRINT")
W !?3,"COUNTY: " S DIC=9000001.51,DR=.03,AG("DRENT")=0 D ^AGDICLK I '$D(AG("LKERR")),AG("LKDATA")]"",$D(^AUTTCOM(AG("LKDATA"),0)) S AG=$P(^(0),U,2) I AG,$D(^AUTTCTY(AG,0)) W $P(^(0),U)
W ?62,"AGE: " S DR=1102.98,DIC=9000001 D ^AGDICLK I '$D(AG("LKERR")),$D(AG("LKPRINT")),+AG("LKPRINT") W AG("LKPRINT")
;W !,"HOME ADDRESS:" S DR=.111,DIC=2 D ^AGDICLK I $D(AG("LKPRINT")),AG("LKPRINT")]"" W !?5,AG("LKPRINT")
W !,"CURRENT ADDRESS:" S DR=.111,DIC=2 D ^AGDICLK I $D(AG("LKPRINT")),AG("LKPRINT")]"" W !?5,AG("LKPRINT") ;AG*7.1*4
F DR=.112,.113 S DIC=2 D ^AGDICLK I $D(AG("LKPRINT")),AG("LKPRINT")]"" W !?5,AG("LKPRINT") ;AG*7.1*7
;W:$$GET1^DIQ(2,DFN_",",.112,"E")'="" !?5,$$GET1^DIQ(2,DFN_",",.112,"E") ;IHS/SD/TPF FOR FOREST COUNTY H5297 NOT APPROVED BY TAG
S AG="",DR=.114 D ^AGDICLK I $D(AG("LKPRINT")),AG("LKPRINT")]"" S AG=AG_AG("LKPRINT")_","
F DR=.115,.116 D ^AGDICLK I $D(AG("LKPRINT")),AG("LKPRINT")]"" S AG=AG_" "_AG("LKPRINT")
W:AG]"" !?5,AG
W !,"PHONE NUMBERS ---"
W !,"HOME: " S DR=.131 D ^AGDICLK W:$D(AG("LKPRINT")) AG("LKPRINT") W ?27,"WORK: " S DR=.132 D ^AGDICLK W:$D(AG("LKPRINT")) AG("LKPRINT") W !,"OTHER PHONE: " S DR=1801 W $$GET1^DIQ(9000001,DFN,DR)
W !
I $$GET1^DIQ(9009061,DUZ(2)_",",503,"I") D ;AG*7.1*9 - Added conditional display of RACE
.;IHS/OIT/NKD AG*7.1*11 MU2 - CHANGED DISPLAY TO USE MULTIPLE FIELD
.;W $$GET1^DID(2,.06,"","LABEL"),": ",$E($$GET1^DIQ(2,DFN,.06),1,38) ;AG*7.1*7 - Truncated field length
.N AGRACE S AGRACE=$$RACE^AGUTL(DFN)
.W "RACE: "_$S(+AGRACE>1:"MULTIPLE RACES SPECIFIED",1:$E($P(AGRACE,"^",2),1,38))
;BEGIN NEW CODE AG*7.1*2 ETHNICITY
I $$GET1^DIQ(9009061,DUZ(2)_",",501,"I") D
.S ETHNIC=$O(^DPT(DFN,.06,0))
.I ETHNIC S ETHNIC=$$GET1^DIQ(10.2,ETHNIC,.01)
.W ?46,"ETHNICITY: ",$G(ETHNIC)
;END NEW CODE
;IHS/OIT/NKD AG*7.1*11 MU2 - RESTRICT PREFERRED LANGUAGE TO 25 CHARS AND SHIFT PREFERRED METHOD OVER
;W !,"PREFERRED LANGUAGE: ",$P($P($$CLANG^AGED10B(DFN),U,4),":",2),?52,"PREFERRED METHOD: ",$$GET1^DIQ(9000001,DFN,4002) ;AG*7.1*9 - Added Preferred Method
W !,"PREFERRED LANGUAGE: ",$E($P($P($$CLANG^AGED10B(DFN),U,4),":",2),1,25),?47,"PREFERRED METHOD: ",$$GET1^DIQ(9000001,DFN,4002)
;NEW CODE FOR EMAIL ADDRESSES AG*7.1*4
W:$$GET1^DIQ(9000001,DFN_",",1802)'="" !,"CURRENT EMAIL ADDRESS: ",$$GET1^DIQ(9000001,DFN_",",1802)
;END NEW CODE FOR EMAIL ADDRESS
I AGOPT(23)="Y" W !,$$GET1^DID(9000001,.35,"","LABEL"),": ",$$GET1^DIQ(9000001,DFN,.35)
I AGOPT(23)="Y" W ?30,$$GET1^DID(9000001,.36,"","LABEL"),": ",$$GET1^DIQ(9000001,DFN,.36)," / ",$$GET1^DIQ(9000001,DFN_",",8701,"E")
I '$D(^AUPNNPP("B",DFN)) W !,AG("-"),!,"*** NO NOTICE OF PRIVACY PRACTICES DATA ON THIS PATIENT ***"
I $D(^AUPNNPP("B",DFN)) D
.W !,AG("-"),!
.W "NOTICE OF PRIVACY PRACTICES REC'D BY PATIENT :" W ?47,$$GET1^DIQ(9000038,DFN,.02)
.W ?54,"DATE :",?61,$$GET1^DIQ(9000038,DFN,.03)
.W !,"ACKNOWLEDGEMENT OF RECEIPT OF NPP SIGNED :"
.W ?43,$$GET1^DIQ(9000038,DFN,.04)
.I $$GET1^DIQ(9000038,DFN,.05)'="" D
..W !,"REASON :"
..W ?11,$E($$GET1^DIQ(9000038,DFN,.05),1,60)
..I $L($$GET1^DIQ(9000038,DFN,.05))>60 W ! W ?11,$E($$GET1^DIQ(9000038,DFN,.05),61,80)
W !,AG("-"),!,"TRIBE: " S DR=1108,DIC=9000001 D ^AGDICLK I $D(AG("LKPRINT")),AG("LKPRINT")]"" W AG("LKPRINT") I AGOPT(14)="Y",$D(^AUPNPAT(DFN,11)) W " (",$S($P(^(11),U,19)="Y":"Verified",1:"Unverified"),")"
W ?50,"INDIAN QUANTUM: " S DR=1110 D ^AGDICLK W:$D(AG("LKPRINT")) AG("LKPRINT")
K AGQUIT
N I F I=1,4,5,6,7,9,11 D Q:$D(AGQUIT)
.I $D(AGQUIT) Q
.I $Y+6>IOSL D HDR
.I $D(AGQUIT) Q
.D @("^AGFACE"_I)
I $D(AGQUIT) K AGQUIT Q
;Write line of "-", Confidential Pat Info, If CPU do end of page
END ;
I $G(AG("VS"))=1 W !,AG("-"),!! F I=0:0 S I=$O(^AGFAC(DUZ(2),4,I)) Q:'I W ^(I,0),!
D CPI^AG G END2:$D(AGVQQFS) D RTRN^AG W $$S^AGVDF("IOF")
END1 D ^%ZISC
END2 ;
K AG,AGIO,AGTIME,G,AGL,AGLAST,AG("LKERR"),AG("LKDATA"),AG("LKPRINT"),AGPCC,X,Y,Z
D:$D(ZTQUEUED) KILL^%ZTLOAD
Q
HDR ;EP - FACE SHEET HEADER
;S AG("PAGE")=AG("PAGE")+1
S AG("PAGE")=$G(AG("PAGE"))+1 ;IHS/SD/TPF 12/15/2005 AG*7.1*1
I AG("PAGE")>1 Q:$D(AGVQQFS) D RTRN^AG I 'Y S AGQUIT="" D END1 Q
W:AG("PAGE")>1 $$S^AGVDF("IOF")
D CPI^AG
W !?40-($L(AG("LOC"))\2),AG("LOC"),!?26,"AMBULATORY CARE RECORD BRIEF",!?25,"------------------------------",!,AGTIME,?70,"Page: ",AG("PAGE"),!,AG("="),!
I '$D(RHIFLAG) W "PATIENT: " S DIC=2,DA=DFN,DR=.01 D ^AGDICLK W:$D(AG("LKPRINT")) AG("LKPRINT") I $D(^DPT(DFN,"VET")),^("VET")="Y" W " (VETERAN)"
I $D(RHIFLAG) D
. I RHIFLAG="A" W "PATIENT: " S DIC=2,DA=DFN,DR=.01 D ^AGDICLK W:$D(AG("LKPRINT")) $$S^AGVDF("RVN"),AG("LKPRINT"),$$S^AGVDF("BLN")," (RHI)",$$S^AGVDF("BLF"),$$S^AGVDF("RVF")
. E W "PATIENT: " S DIC=2,DA=DFN,DR=.01 D ^AGDICLK W:$D(AG("LKPRINT")) AG("LKPRINT") I $D(^DPT(DFN,"VET")),^("VET")="Y" W " (VETERAN)"
W ?59,"CHART #: " W:$D(^AUPNPAT(DFN,41,DUZ(2),0)) $P(^(0),U,2) W !,AG("="),!
Q
QUE ;QUE TO TASKMAN
K IO("Q")
S ZTRTN="START^AGFACE",ZTDESC="FACE SHEET for "_$P(^DPT(DFN,0),U)_"."
S ZTSAVE("DFN")=""
K ZTSK D ^%ZTLOAD
I $D(ZTSK)[0 W !!?5,"Report Cancelled!"
E W !!?5,"Task # ",ZTSK," queued.",!
H 3
Q
PRINTVS ;PRINT VALIDATION STATEMENT
K DIR,AG("VS")
S DIR(0)="Y"
S DIR("A")="Print VALIDATION STATEMENT on form ?"
S DIR("B")="NO"
D ^DIR S AG("VS")=Y
K DIR
Q
AGFACE ; IHS/ASDS/EFG - FACE SHEET ; MAR 19, 2010
+1 ;;7.1;PATIENT REGISTRATION;**1,2,4,5,7,9,11**;AUG 25, 2005;Build 1
+2 ;IHS/OIT/NKD AG*7.1*11 MU2 MULTIPLE RACES
+3 ;IHS/OIT/NKD AG*7.1*11 MU2 PREFERRED METHOD
+4 ;
NODFN ;EP - No Pre-Defined Patient Number.
+1 DO PTLK^AG
+2 IF '$DATA(DFN)
QUIT
+3 GOTO L1
DFN ;PEP - Pre-Defined Patient Number.
+1 IF '$DATA(DFN)
QUIT
+2 DO CHKRHI^AG
+3 IF $DATA(RHIFLAG)&(RHIFLAG="A")
WRITE !,$$S^AGVDF("RVN"),$$S^AGVDF("BLN"),"This patient has Restricted Health Information",$$S^AGVDF("BLF"),$$S^AGVDF("RVF")
L1 KILL AG
IF '$DATA(DFN)
QUIT
DO ^AGDATCK
IF AG("DTOT")>0
DO ^AGBADATA
+1 IF AGOPT(24)="Y"
DO PRINTVS
DEV ;
+1 ;S XBNS="AG;DFN",XBRP="START^AGFACE" D ^XBDBQUE
+2 ;IM22794 ERROR DURING ALPHA TESTING. NOT REPORTED BY SITE
+3 SET %ZIS="QA"
+4 DO ^%ZIS
+5 IF POP
GOTO NODFN
+6 IF $GET(IO("Q"))
DO QUE
DO HOME^%ZIS
QUIT
+7 USE IO
+8 DO START
+9 DO ^%ZISC
+10 DO HOME^%ZIS
+11 QUIT
START ;PEP - From TaskMan.
+1 ;IHS/SD/TPF AG*7.1*1 REPORTED BY FDIH CALL FROM CIA REMOTE
IF '$GET(DFN)
QUIT
+2 ;PROCEDURE HAD DFN=0 IM18987
+3 IF '$GET(DUZ(2))
QUIT
+4 DO ^AGVAR
DO LINES^AG
DO NOW^AG
SET AG("LOC")=$PIECE($GET(^DIC(4,DUZ(2),0)),U)
+5 SET AG("PAGE")=0
DO HDR
+6 SET DIC=9000001
SET DR=.02
DO ^AGDICLK
WRITE "COMPUTER FILE EST: "
IF $DATA(AG("LKPRINT"))
WRITE AG("LKPRINT")
SET AG=$PIECE($GET(^AUPNPAT(DFN,0)),U,11)
IF AG
IF $DATA(^VA(200,AG,0))
WRITE "(",$PIECE(^(0),U,2),")"
+7 SET DR=.03
SET AGLAST="LAST EDIT: "
DO ^AGDICLK
+8 IF $DATA(AG("LKPRINT"))
SET AGLAST=AGLAST_AG("LKPRINT")
SET AG=$PIECE($GET(^AUPNPAT(DFN,0)),U,12)
IF AG
IF $DATA(^VA(200,AG,0))
SET AGLAST=AGLAST_" ("_$PIECE(^(0),U,2)_")"
+9 WRITE ?78-$LENGTH(AGLAST),AGLAST,!,AG("-")
ALIAS ;OTHER NAMES
+1 IF $ORDER(^DPT(DFN,.01,0))
Begin DoDot:1
+2 WRITE !,"OTHER NAME(S):"
+3 NEW I
SET I=0
FOR
SET I=$ORDER(^DPT(DFN,.01,I))
IF 'I
QUIT
Begin DoDot:2
+4 WRITE ?16,$PIECE(^DPT(DFN,.01,I,0),"^",1),!
End DoDot:2
End DoDot:1
+5 IF '$TEST
WRITE !
+6 SET DR=.09
SET DIC=2
DO ^AGDICLK
+7 ;I $D(AG("LKPRINT")) W "SSN: ",AG("LKPRINT") D
+8 ;I $$GET1^DIQ(2,DFN_",",1107.3)'="" W "SSN: ",$$GET1^DIQ(9000001,DFN_",",1107.3) D ;IHS/SD/TPF AG*7.1*4
+9 ;IHS/SD/TPF AG*7.1*5
IF $$GET1^DIQ(9000001,DFN_",",1107.3)'=""
WRITE "SSN: ",$$GET1^DIQ(9000001,DFN_",",1107.3)
Begin DoDot:1
+10 IF $PIECE(^AUPNPAT(DA,0),U,23)
WRITE ?40,"SSN STATUS: ",$PIECE(^AUTTSSN($PIECE(^(0),U,23),0),U,2)
+11 IF '$TEST
WRITE ?40,"SSN STATUS UNKNOWN"
End DoDot:1
+12 WRITE !,"CLASS: "
SET DR=1111
SET DIC=9000001
DO ^AGDICLK
IF $DATA(AG("LKPRINT"))
WRITE AG("LKPRINT")
+13 WRITE ?62,"SEX: "
SET DR=.02
SET DIC=2
DO ^AGDICLK
IF $DATA(AG("LKPRINT"))
WRITE AG("LKPRINT")
+14 WRITE !,"COMMUNITY: "
SET DR=1118
SET DIC=9000001
DO ^AGDICLK
IF $DATA(AG("LKPRINT"))
WRITE AG("LKPRINT")
IF AGOPT(14)="Y"
IF $DATA(^AUPNPAT(DFN,11))
WRITE " (",$SELECT($PIECE(^(11),U,21)="Y":"Verified",1:"Unverified"),")"
+15 WRITE ?57,"BIRTHDAY: "
SET DR=.03
SET DIC=2
DO ^AGDICLK
IF $DATA(AG("LKPRINT"))
WRITE AG("LKPRINT")
+16 WRITE !?3,"COUNTY: "
SET DIC=9000001.51
SET DR=.03
SET AG("DRENT")=0
DO ^AGDICLK
IF '$DATA(AG("LKERR"))
IF AG("LKDATA")]""
IF $DATA(^AUTTCOM(AG("LKDATA"),0))
SET AG=$PIECE(^(0),U,2)
IF AG
IF $DATA(^AUTTCTY(AG,0))
WRITE $PIECE(^(0),U)
+17 WRITE ?62,"AGE: "
SET DR=1102.98
SET DIC=9000001
DO ^AGDICLK
IF '$DATA(AG("LKERR"))
IF $DATA(AG("LKPRINT"))
IF +AG("LKPRINT")
WRITE AG("LKPRINT")
+18 ;W !,"HOME ADDRESS:" S DR=.111,DIC=2 D ^AGDICLK I $D(AG("LKPRINT")),AG("LKPRINT")]"" W !?5,AG("LKPRINT")
+19 ;AG*7.1*4
WRITE !,"CURRENT ADDRESS:"
SET DR=.111
SET DIC=2
DO ^AGDICLK
IF $DATA(AG("LKPRINT"))
IF AG("LKPRINT")]""
WRITE !?5,AG("LKPRINT")
+20 ;AG*7.1*7
FOR DR=.112,.113
SET DIC=2
DO ^AGDICLK
IF $DATA(AG("LKPRINT"))
IF AG("LKPRINT")]""
WRITE !?5,AG("LKPRINT")
+21 ;W:$$GET1^DIQ(2,DFN_",",.112,"E")'="" !?5,$$GET1^DIQ(2,DFN_",",.112,"E") ;IHS/SD/TPF FOR FOREST COUNTY H5297 NOT APPROVED BY TAG
+22 SET AG=""
SET DR=.114
DO ^AGDICLK
IF $DATA(AG("LKPRINT"))
IF AG("LKPRINT")]""
SET AG=AG_AG("LKPRINT")_","
+23 FOR DR=.115,.116
DO ^AGDICLK
IF $DATA(AG("LKPRINT"))
IF AG("LKPRINT")]""
SET AG=AG_" "_AG("LKPRINT")
+24 IF AG]""
WRITE !?5,AG
+25 WRITE !,"PHONE NUMBERS ---"
+26 WRITE !,"HOME: "
SET DR=.131
DO ^AGDICLK
IF $DATA(AG("LKPRINT"))
WRITE AG("LKPRINT")
WRITE ?27,"WORK: "
SET DR=.132
DO ^AGDICLK
IF $DATA(AG("LKPRINT"))
WRITE AG("LKPRINT")
WRITE !,"OTHER PHONE: "
SET DR=1801
WRITE $$GET1^DIQ(9000001,DFN,DR)
+27 WRITE !
+28 ;AG*7.1*9 - Added conditional display of RACE
IF $$GET1^DIQ(9009061,DUZ(2)_",",503,"I")
Begin DoDot:1
+29 ;IHS/OIT/NKD AG*7.1*11 MU2 - CHANGED DISPLAY TO USE MULTIPLE FIELD
+30 ;W $$GET1^DID(2,.06,"","LABEL"),": ",$E($$GET1^DIQ(2,DFN,.06),1,38) ;AG*7.1*7 - Truncated field length
+31 NEW AGRACE
SET AGRACE=$$RACE^AGUTL(DFN)
+32 WRITE "RACE: "_$SELECT(+AGRACE>1:"MULTIPLE RACES SPECIFIED",1:$EXTRACT($PIECE(AGRACE,"^",2),1,38))
End DoDot:1
+33 ;BEGIN NEW CODE AG*7.1*2 ETHNICITY
+34 IF $$GET1^DIQ(9009061,DUZ(2)_",",501,"I")
Begin DoDot:1
+35 SET ETHNIC=$ORDER(^DPT(DFN,.06,0))
+36 IF ETHNIC
SET ETHNIC=$$GET1^DIQ(10.2,ETHNIC,.01)
+37 WRITE ?46,"ETHNICITY: ",$GET(ETHNIC)
End DoDot:1
+38 ;END NEW CODE
+39 ;IHS/OIT/NKD AG*7.1*11 MU2 - RESTRICT PREFERRED LANGUAGE TO 25 CHARS AND SHIFT PREFERRED METHOD OVER
+40 ;W !,"PREFERRED LANGUAGE: ",$P($P($$CLANG^AGED10B(DFN),U,4),":",2),?52,"PREFERRED METHOD: ",$$GET1^DIQ(9000001,DFN,4002) ;AG*7.1*9 - Added Preferred Method
+41 WRITE !,"PREFERRED LANGUAGE: ",$EXTRACT($PIECE($PIECE($$CLANG^AGED10B(DFN),U,4),":",2),1,25),?47,"PREFERRED METHOD: ",$$GET1^DIQ(9000001,DFN,4002)
+42 ;NEW CODE FOR EMAIL ADDRESSES AG*7.1*4
+43 IF $$GET1^DIQ(9000001,DFN_",",1802)'=""
WRITE !,"CURRENT EMAIL ADDRESS: ",$$GET1^DIQ(9000001,DFN_",",1802)
+44 ;END NEW CODE FOR EMAIL ADDRESS
+45 IF AGOPT(23)="Y"
WRITE !,$$GET1^DID(9000001,.35,"","LABEL"),": ",$$GET1^DIQ(9000001,DFN,.35)
+46 IF AGOPT(23)="Y"
WRITE ?30,$$GET1^DID(9000001,.36,"","LABEL"),": ",$$GET1^DIQ(9000001,DFN,.36)," / ",$$GET1^DIQ(9000001,DFN_",",8701,"E")
+47 IF '$DATA(^AUPNNPP("B",DFN))
WRITE !,AG("-"),!,"*** NO NOTICE OF PRIVACY PRACTICES DATA ON THIS PATIENT ***"
+48 IF $DATA(^AUPNNPP("B",DFN))
Begin DoDot:1
+49 WRITE !,AG("-"),!
+50 WRITE "NOTICE OF PRIVACY PRACTICES REC'D BY PATIENT :"
WRITE ?47,$$GET1^DIQ(9000038,DFN,.02)
+51 WRITE ?54,"DATE :",?61,$$GET1^DIQ(9000038,DFN,.03)
+52 WRITE !,"ACKNOWLEDGEMENT OF RECEIPT OF NPP SIGNED :"
+53 WRITE ?43,$$GET1^DIQ(9000038,DFN,.04)
+54 IF $$GET1^DIQ(9000038,DFN,.05)'=""
Begin DoDot:2
+55 WRITE !,"REASON :"
+56 WRITE ?11,$EXTRACT($$GET1^DIQ(9000038,DFN,.05),1,60)
+57 IF $LENGTH($$GET1^DIQ(9000038,DFN,.05))>60
WRITE !
WRITE ?11,$EXTRACT($$GET1^DIQ(9000038,DFN,.05),61,80)
End DoDot:2
End DoDot:1
+58 WRITE !,AG("-"),!,"TRIBE: "
SET DR=1108
SET DIC=9000001
DO ^AGDICLK
IF $DATA(AG("LKPRINT"))
IF AG("LKPRINT")]""
WRITE AG("LKPRINT")
IF AGOPT(14)="Y"
IF $DATA(^AUPNPAT(DFN,11))
WRITE " (",$SELECT($PIECE(^(11),U,19)="Y":"Verified",1:"Unverified"),")"
+59 WRITE ?50,"INDIAN QUANTUM: "
SET DR=1110
DO ^AGDICLK
IF $DATA(AG("LKPRINT"))
WRITE AG("LKPRINT")
+60 KILL AGQUIT
+61 NEW I
FOR I=1,4,5,6,7,9,11
Begin DoDot:1
+62 IF $DATA(AGQUIT)
QUIT
+63 IF $Y+6>IOSL
DO HDR
+64 IF $DATA(AGQUIT)
QUIT
+65 DO @("^AGFACE"_I)
End DoDot:1
IF $DATA(AGQUIT)
QUIT
+66 IF $DATA(AGQUIT)
KILL AGQUIT
QUIT
+67 ;Write line of "-", Confidential Pat Info, If CPU do end of page
END ;
+1 IF $GET(AG("VS"))=1
WRITE !,AG("-"),!!
FOR I=0:0
SET I=$ORDER(^AGFAC(DUZ(2),4,I))
IF 'I
QUIT
WRITE ^(I,0),!
+2 DO CPI^AG
IF $DATA(AGVQQFS)
GOTO END2
DO RTRN^AG
WRITE $$S^AGVDF("IOF")
END1 DO ^%ZISC
END2 ;
+1 KILL AG,AGIO,AGTIME,G,AGL,AGLAST,AG("LKERR"),AG("LKDATA"),AG("LKPRINT"),AGPCC,X,Y,Z
+2 IF $DATA(ZTQUEUED)
DO KILL^%ZTLOAD
+3 QUIT
HDR ;EP - FACE SHEET HEADER
+1 ;S AG("PAGE")=AG("PAGE")+1
+2 ;IHS/SD/TPF 12/15/2005 AG*7.1*1
SET AG("PAGE")=$GET(AG("PAGE"))+1
+3 IF AG("PAGE")>1
IF $DATA(AGVQQFS)
QUIT
DO RTRN^AG
IF 'Y
SET AGQUIT=""
DO END1
QUIT
+4 IF AG("PAGE")>1
WRITE $$S^AGVDF("IOF")
+5 DO CPI^AG
+6 WRITE !?40-($LENGTH(AG("LOC"))\2),AG("LOC"),!?26,"AMBULATORY CARE RECORD BRIEF",!?25,"------------------------------",!,AGTIME,?70,"Page: ",AG("PAGE"),!,AG("="),!
+7 IF '$DATA(RHIFLAG)
WRITE "PATIENT: "
SET DIC=2
SET DA=DFN
SET DR=.01
DO ^AGDICLK
IF $DATA(AG("LKPRINT"))
WRITE AG("LKPRINT")
IF $DATA(^DPT(DFN,"VET"))
IF ^("VET")="Y"
WRITE " (VETERAN)"
+8 IF $DATA(RHIFLAG)
Begin DoDot:1
+9 IF RHIFLAG="A"
WRITE "PATIENT: "
SET DIC=2
SET DA=DFN
SET DR=.01
DO ^AGDICLK
IF $DATA(AG("LKPRINT"))
WRITE $$S^AGVDF("RVN"),AG("LKPRINT"),$$S^AGVDF("BLN")," (RHI)",$$S^AGVDF("BLF"),$$S^AGVDF("RVF")
+10 IF '$TEST
WRITE "PATIENT: "
SET DIC=2
SET DA=DFN
SET DR=.01
DO ^AGDICLK
IF $DATA(AG("LKPRINT"))
WRITE AG("LKPRINT")
IF $DATA(^DPT(DFN,"VET"))
IF ^("VET")="Y"
WRITE " (VETERAN)"
End DoDot:1
+11 WRITE ?59,"CHART #: "
IF $DATA(^AUPNPAT(DFN,41,DUZ(2),0))
WRITE $PIECE(^(0),U,2)
WRITE !,AG("="),!
+12 QUIT
QUE ;QUE TO TASKMAN
+1 KILL IO("Q")
+2 SET ZTRTN="START^AGFACE"
SET ZTDESC="FACE SHEET for "_$PIECE(^DPT(DFN,0),U)_"."
+3 SET ZTSAVE("DFN")=""
+4 KILL ZTSK
DO ^%ZTLOAD
+5 IF $DATA(ZTSK)[0
WRITE !!?5,"Report Cancelled!"
+6 IF '$TEST
WRITE !!?5,"Task # ",ZTSK," queued.",!
+7 HANG 3
+8 QUIT
PRINTVS ;PRINT VALIDATION STATEMENT
+1 KILL DIR,AG("VS")
+2 SET DIR(0)="Y"
+3 SET DIR("A")="Print VALIDATION STATEMENT on form ?"
+4 SET DIR("B")="NO"
+5 DO ^DIR
SET AG("VS")=Y
+6 KILL DIR
+7 QUIT
