- 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
