AGED ; IHS/ASDS/EFG - EDITOR MAIN ROUTINE ; MAR 19, 2010
;;7.1;PATIENT REGISTRATION;**2,4,7,9**;AUG 25, 2005
;
I '$D(IOF) D HOME^%ZIS
W $$S^AGVDF("IOF"),!
D PROGVIEW^AGUTILS(DUZ)
W "IHS REGISTRATION ",$S($D(AGSEENLY):"VIEW SCREEN",1:"EDITOR")
;ONLY SHOW PAGE# IF NOT DISPLAYING INS CATEGORY SCREEN
I '$D(SEQHD) W " (page ",+AG("PG"),")"
W ?78-$L($P($G(^DIC(4,DUZ(2),0)),U)),$P($G(^DIC(4,DUZ(2),0)),U)
S $P(AGLINE("-"),"-",81)=""
S $P(AGLINE("EQ"),"=",81)=""
W !,AGLINE("EQ")
I '$D(AGPAT) S AGPAT=$P($G(^DPT(DFN,0)),U)
D CHKNPP^AG,CHKRHI^AG
I '$D(RHIFLAG) W !,AGPAT
I $D(RHIFLAG) D
. I RHIFLAG'="A" W !,AGPAT
. I $D(RHIFLAG) D
. I RHIFLAG="A" W !,$$S^AGVDF("RVN"),AGPAT,$$S^AGVDF("BLN")," (RHI)",$$S^AGVDF("BLF"),$$S^AGVDF("RVF")
;W ?36,$$DTEST^AGUTILS(DFN)
W ?27,$$DTEST^AGUTILS(DFN) ;AG*7.1*4
I $D(AGCHRT) W ?55,"HRN:",AGCHRT
I AG("PG")>1 D
. ; GET ELIGIBILITY STATUS
. S AGELSTS=$P($G(^AUPNPAT(DFN,11)),U,12)
. W ?66,$S(AGELSTS="C":"CHS & DIRECT",AGELSTS="I":"INELIGIBLE",AGELSTS="D":"DIRECT ONLY",AGELSTS="P":"PEND. VERIF",1:"NONE")
W !,AGLINE("EQ")
G:AG("PG")="5BEB"!(AG("PG")="5BEC")!(AG("PG")="5BEA")!(AG("PG")="5BED")!(AG("PG")="5BEF")!(AG("PG")="5BEE")!(AG("PG")="4TPLA")!(AG("PG")="4GUARA")!(AG("PG")="4WCA")!(AG("PG")="4RRA") END
I AG("PG")'=4 D
. W !?$P($T(@AG("PG")),";",3),$P($T(@AG("PG")),";",4)
I AG("PG")=4&('$D(CATHD)) D
. ;W !?30,"MEDICAL COVERAGE"
. W !?30,"SUMMARY COVERAGE" ;IHS/SD/TPF 4/12/2006 AG*7.1*2 ITEM 9 PAGE 11
I AG("PG")=4&($D(CATHD)) D
. W !?78-$L(CATHD)/2,CATHD
END ;
K DR,DIE,AG("ED"),AGDTS
Q
UPDATE ;PEP - CALLED FROM PCC TO UPDATE AGPATCH FILE
I $D(AG("NOUPDATE")) G END
D UPDATE1^AGED(DUZ(2),DFN,"","")
Q ;generate extrinsic from general call to update
UPDATE1(AGSITE,AGZDFN,AGPTPG,AGGDA) ;EP - extrinsic here
I '$D(DIU(0)),DUZ'=.5,'$D(APMFVAR) ;test re-index,filegram,mfi
E K AGPTPG,AGZDFN G END
D NOW^%DTC
S AGDTS=%
D ^XBNEW("XBDIE^AGED:AG*") ;call XBDIE fpr nested DIE call
Q
XBDIE ;NESTED DIE
S:'$D(^AGPATCH(AGDTS,AGSITE,AGZDFN)) ^AGPATCH(AGDTS,AGSITE,AGZDFN)=""
ZMFI ;
;set zmfi node in ^AGPATCH(agdts,site,dfn,zmfi,pg)=da
I $G(AGPTPG)]"",("N"'[($P($G(^AUTTSITE(1,0)),U,16))) D
. S ^AGPATCH(AGDTS,AGSITE,AGZDFN,"ZMFI",AGPTPG)=AGGDA
. K AGPTPG ;add mfi pgs with ien
S DIE="^AUPNPAT("
S DR=".03///TODAY"
S $P(^AUPNPAT(AGZDFN,0),U,12)=DUZ
S DA=AGZDFN
D ^DIE
S DIE="^AUPNPAT("
S DR=".16///TODAY"
S DA=AGZDFN
D ^DIE
S Y=DT
D DD^%DT
S AGUPDT="(upd:"_Y_")"
;HL7 INTERFACE -- PUT PATIENT DFN INTO TEMP ARRAY FOR HL7 CALL
S ^XTMP("AGHL7",DUZ(2),DA)=DA ;AG*7.1*9 - Added DUZ(2) subscript
S ^XTMP("AGHL7AG",DUZ(2),DA,"UPDATE")="" ;AG*7.1*9 - Added DUZ(2) subscript
K AGZDFN,AGPTPG
G END
Q
;
1 ;;0;
2 ;;21;Religion/Tribal Data/Employment
3 ;;24;Emergency Contact/Next of Kin
4 ;;30;Medical Sequencing
5 ;;0;
6 ;;28;Veteran's Information
7 ;;26;Death Info/Other Names
8 ;;0;
9 ;;23;CHS Eligibility & Document Summary
10 ;;30;Other Patient Data
11 ;;0;
BICFLDS ;;35;BIC Fields
SCRN ;;Label DY^Label DX^File Number^Field;;Data Format for drawing EDIT screens.
;
Q
AGED ; IHS/ASDS/EFG - EDITOR MAIN ROUTINE ; MAR 19, 2010
+1 ;;7.1;PATIENT REGISTRATION;**2,4,7,9**;AUG 25, 2005
+2 ;
+3 IF '$DATA(IOF)
DO HOME^%ZIS
+4 WRITE $$S^AGVDF("IOF"),!
+5 DO PROGVIEW^AGUTILS(DUZ)
+6 WRITE "IHS REGISTRATION ",$SELECT($DATA(AGSEENLY):"VIEW SCREEN",1:"EDITOR")
+7 ;ONLY SHOW PAGE# IF NOT DISPLAYING INS CATEGORY SCREEN
+8 IF '$DATA(SEQHD)
WRITE " (page ",+AG("PG"),")"
+9 WRITE ?78-$LENGTH($PIECE($GET(^DIC(4,DUZ(2),0)),U)),$PIECE($GET(^DIC(4,DUZ(2),0)),U)
+10 SET $PIECE(AGLINE("-"),"-",81)=""
+11 SET $PIECE(AGLINE("EQ"),"=",81)=""
+12 WRITE !,AGLINE("EQ")
+13 IF '$DATA(AGPAT)
SET AGPAT=$PIECE($GET(^DPT(DFN,0)),U)
+14 DO CHKNPP^AG
DO CHKRHI^AG
+15 IF '$DATA(RHIFLAG)
WRITE !,AGPAT
+16 IF $DATA(RHIFLAG)
Begin DoDot:1
+17 IF RHIFLAG'="A"
WRITE !,AGPAT
+18 IF $DATA(RHIFLAG)
Begin DoDot:2
End DoDot:2
+19 IF RHIFLAG="A"
WRITE !,$$S^AGVDF("RVN"),AGPAT,$$S^AGVDF("BLN")," (RHI)",$$S^AGVDF("BLF"),$$S^AGVDF("RVF")
End DoDot:1
+20 ;W ?36,$$DTEST^AGUTILS(DFN)
+21 ;AG*7.1*4
WRITE ?27,$$DTEST^AGUTILS(DFN)
+22 IF $DATA(AGCHRT)
WRITE ?55,"HRN:",AGCHRT
+23 IF AG("PG")>1
Begin DoDot:1
+24 ; GET ELIGIBILITY STATUS
+25 SET AGELSTS=$PIECE($GET(^AUPNPAT(DFN,11)),U,12)
+26 WRITE ?66,$SELECT(AGELSTS="C":"CHS & DIRECT",AGELSTS="I":"INELIGIBLE",AGELSTS="D":"DIRECT ONLY",AGELSTS="P":"PEND. VERIF",1:"NONE")
End DoDot:1
+27 WRITE !,AGLINE("EQ")
+28 IF AG("PG")="5BEB"!(AG("PG")="5BEC")!(AG("PG")="5BEA")!(AG("PG")="5BED")!(AG("PG")="5BEF")!(AG("PG")="5BEE")!(AG("PG")="4TPLA")!(AG("PG")="4GUARA")!(AG("PG")="4WCA")!(AG("PG")="4RRA")
GOTO END
+29 IF AG("PG")'=4
Begin DoDot:1
+30 WRITE !?$PIECE($TEXT(@AG("PG")),";",3),$PIECE($TEXT(@AG("PG")),";",4)
End DoDot:1
+31 IF AG("PG")=4&('$DATA(CATHD))
Begin DoDot:1
+32 ;W !?30,"MEDICAL COVERAGE"
+33 ;IHS/SD/TPF 4/12/2006 AG*7.1*2 ITEM 9 PAGE 11
WRITE !?30,"SUMMARY COVERAGE"
End DoDot:1
+34 IF AG("PG")=4&($DATA(CATHD))
Begin DoDot:1
+35 WRITE !?78-$LENGTH(CATHD)/2,CATHD
End DoDot:1
END ;
+1 KILL DR,DIE,AG("ED"),AGDTS
+2 QUIT
UPDATE ;PEP - CALLED FROM PCC TO UPDATE AGPATCH FILE
+1 IF $DATA(AG("NOUPDATE"))
GOTO END
+2 DO UPDATE1^AGED(DUZ(2),DFN,"","")
+3 ;generate extrinsic from general call to update
QUIT
UPDATE1(AGSITE,AGZDFN,AGPTPG,AGGDA) ;EP - extrinsic here
+1 ;test re-index,filegram,mfi
IF '$DATA(DIU(0))
IF DUZ'=.5
IF '$DATA(APMFVAR)
+2 IF '$TEST
KILL AGPTPG,AGZDFN
GOTO END
+3 DO NOW^%DTC
+4 SET AGDTS=%
+5 ;call XBDIE fpr nested DIE call
DO ^XBNEW("XBDIE^AGED:AG*")
+6 QUIT
XBDIE ;NESTED DIE
+1 IF '$DATA(^AGPATCH(AGDTS,AGSITE,AGZDFN))
SET ^AGPATCH(AGDTS,AGSITE,AGZDFN)=""
ZMFI ;
+1 ;set zmfi node in ^AGPATCH(agdts,site,dfn,zmfi,pg)=da
+2 IF $GET(AGPTPG)]""
IF ("N"'[($PIECE($GET(^AUTTSITE(1,0)),U,16)))
Begin DoDot:1
+3 SET ^AGPATCH(AGDTS,AGSITE,AGZDFN,"ZMFI",AGPTPG)=AGGDA
+4 ;add mfi pgs with ien
KILL AGPTPG
End DoDot:1
+5 SET DIE="^AUPNPAT("
+6 SET DR=".03///TODAY"
+7 SET $PIECE(^AUPNPAT(AGZDFN,0),U,12)=DUZ
+8 SET DA=AGZDFN
+9 DO ^DIE
+10 SET DIE="^AUPNPAT("
+11 SET DR=".16///TODAY"
+12 SET DA=AGZDFN
+13 DO ^DIE
+14 SET Y=DT
+15 DO DD^%DT
+16 SET AGUPDT="(upd:"_Y_")"
+17 ;HL7 INTERFACE -- PUT PATIENT DFN INTO TEMP ARRAY FOR HL7 CALL
+18 ;AG*7.1*9 - Added DUZ(2) subscript
SET ^XTMP("AGHL7",DUZ(2),DA)=DA
+19 ;AG*7.1*9 - Added DUZ(2) subscript
SET ^XTMP("AGHL7AG",DUZ(2),DA,"UPDATE")=""
+20 KILL AGZDFN,AGPTPG
+21 GOTO END
+22 QUIT
+23 ;
1 ;;0;
2 ;;21;Religion/Tribal Data/Employment
3 ;;24;Emergency Contact/Next of Kin
4 ;;30;Medical Sequencing
5 ;;0;
6 ;;28;Veteran's Information
7 ;;26;Death Info/Other Names
8 ;;0;
9 ;;23;CHS Eligibility & Document Summary
10 ;;30;Other Patient Data
11 ;;0;
BICFLDS ;;35;BIC Fields
SCRN ;;Label DY^Label DX^File Number^Field;;Data Format for drawing EDIT screens.
+1 ;
+2 QUIT
