AGCAT ;IHS/SD/EFG - WORK WITH CATEGORY PRIORITIZING ; MAR 19, 2010
;;7.1;PATIENT REGISTRATION;**1,2,7**;AUG 25, 2005
;THIS ROUTINE WAS CREATED TO REMOVE THESE SUBROUTINES
;FROM ^AGED4A DUE TO ROUTINE SIZE RESTRICTIONS
Q
BLDAGCAT ;EP - LOAD ARRAY "AGCAT" WITH SEQUENCED INSURERS
K AGCAT(CATPTR,SEQEFDT)
N AGSEL,AGI,AGC,INS,COV,RECPTR,EBEG,EEND,PHOLDER,POLNUM,ST,STPTR,PLANPTR
S AGSEL=0
S AGI=""
F AGC=1:1 S AGI=$P(PRSEQ,",",AGC) Q:AGI="" D
. S AGSEL=AGSEL+1
. S INS=$P(AGINS(AGI),U,2)
. S COV=$P(AGINS(AGI),U,4)
. S EBEG=$P(AGINS(AGI),U,5)
. S EEND=$P(AGINS(AGI),U,6)
. S PHPTR=$P(AGINS(AGI),U,7)
. S POLNUM=$P(AGINS(AGI),U,9)
. S RECPTR=$P(AGINS(AGI),U,11)
. S PLANPTR=$P(AGINS(AGI),U,12)
. ;S AGCAT(CATPTR,SEQEFDT,AGSEL)=INS_"^"_COV_"^"_EBEG_"^"_EEND_"^"_PHPTR_"^"_POLNUM_"^"_SEQEFDT_"^"_PLANPTR_U_RECPTR
. S USER=DUZ
. S AGCAT(CATPTR,SEQEFDT,AGSEL)=INS_"^"_COV_"^"_EBEG_"^"_EEND_"^"_PHPTR_"^"_POLNUM_"^"_SEQEFDT_"^"_PLANPTR_"^"_USER_"^"_DT_U_RECPTR
;"^"_USER_"^"_ENTDAT_U_RECPTR
I $D(^AUPNICP("EFF2",DFN,SEQEFDT,CATPTR)) D DELICP
Q
LOADICP ;EP - LOAD THE CATEGORY PRIORITIZING GLOBAL WITH WHAT
;THE USER CATEGORIZED AND SEQUENCED IN ARRAY "AGCAT"
N AGA,AGDT,AGB,CATREC,EFFDT,PATIEN,X
N INS,COV,EBEG,EEND,PHOLDER,POLNUM,ST,PLANPTR
S AGA=""
F S AGA=$O(AGCAT(AGA)) Q:AGA="" D ; AGA = CATEGORY
. S AGDT=""
. F S AGDT=$O(AGCAT(AGA,AGDT)) Q:AGDT="" D ; AGDT = PRIORITY EFF DT
.. I '$D(^AUPNICP("EFF2",DFN,AGDT,AGA)) D
... S AGB=0
... F S AGB=$O(AGCAT(AGA,AGDT,AGB)) Q:'AGB D ; AGB = SEQUENCE
.... S CATREC=$G(AGCAT(AGA,AGDT,AGB))
.... ; ADD NEW RECORD TO AUPNICP
.... S INS=$P(CATREC,U)
.... S COV=$P(CATREC,U,2)
.... S EBEG=$P(CATREC,U,3)
.... S EEND=$P(CATREC,U,4)
.... S PHOLDER=$P(CATREC,U,5)
.... S POLNUM=$P(CATREC,U,6)
.... S EFFDT=$P(CATREC,U,7)
.... S PLANPTR=$P(CATREC,U,8)
.... ;S RECPTR=$P(CATREC,U,9)
.... S RECPTR=$P(CATREC,U,11)
.... S USER=DUZ
.... S PATIEN=DFN
.... S DIC="^AUPNICP("
.... S DIC(0)="L"
.... S DLAYGO=9000035
.... S DIC("DR")=".02////^S X=PATIEN"
.... S DIC("DR")=DIC("DR")_";.03////^S X=INS"
.... S DIC("DR")=DIC("DR")_";.04////^S X=AGA"
.... S DIC("DR")=DIC("DR")_";.05///^S X=AGB"
.... S DIC("DR")=DIC("DR")_";.06////^S X=EFFDT"
.... S DIC("DR")=DIC("DR")_";.07///^S X=COV"
.... S DIC("DR")=DIC("DR")_";.08////^S X=EBEG"
.... S DIC("DR")=DIC("DR")_";.09////^S X=EEND"
.... S DIC("DR")=DIC("DR")_";.11///^S X=POLNUM"
.... S DIC("DR")=DIC("DR")_";.12////^S X=PLANPTR"
.... S DIC("DR")=DIC("DR")_";.13///^S X=PHOLDER"
.... ;S DIC("DR")=DIC("DR")_";.14///^S X=USER"
.... S DIC("DR")=DIC("DR")_";.14////"_DUZ ;AG*7.1*1 IM18549;IM8663
.... S DIC("DR")=DIC("DR")_";.15///^S X=RECPTR"
.... W "."
.... H 1 ;ED EXPLAINED THIS WAS IN HERE TO MAKE SURE EACH .01 ENTRY WAS A
.... ;DATE TIME STAMP. HE WAS NOT SURE WHETHER IT WAS FOR FUTURE USE AND API OR
.... ;OR AN IMMEDIATE NEED.
.... D NOW^%DTC
.... S X=%
.... K DD,DO,DINUM
.... D FILE^DICN
.... K DIC
Q
DELICP ;DELETE RE-CATEGORIZED RECORDS IN "^AUPNICP" BASED ON ARRAY "AGCAT"
N AGB,DA
S AGB=0
F S AGB=$O(^AUPNICP("EFF2",DFN,SEQEFDT,CATPTR,AGB)) Q:'AGB D
. S DA=AGB
. S DIK="^AUPNICP("
. D ^DIK
Q
LOADCAT ;EP - FIND PATIENT'S RECORDS IN CATEGORY PRIORITIZING GLOBAL (AUPNICP)
;AND LOAD INTO ARRAY "AGCAT"
N CPTR,SQDT,RECNO,RECORD,SEQEFDT,AGSEL,RECPTR
N ST,INS,COV,EBEG,EEND,PHOLDER,POLNUM,PLANPTR
K AGCAT ;IHS/SD/TPF 5/1/2006 AG*7.1*2 IM20494
S CPTR=""
F S CPTR=$O(^AUPNICP("EFF",DFN,CPTR)) Q:CPTR="" D
. S SQDT=""
. F S SQDT=$O(^AUPNICP("EFF",DFN,CPTR,SQDT)) Q:'SQDT D
.. S RECNO=0
.. F S RECNO=$O(^AUPNICP("EFF",DFN,CPTR,SQDT,RECNO)) Q:'RECNO D
... S RECORD=$G(^AUPNICP(RECNO,0))
... S ENTDAT=$P(RECORD,U)
... S SEQEFDT=$P(RECORD,U,6)
... I $P(RECORD,U,7)="",$P(RECORD,U,8)="",$P(RECORD,U,9)="",$P(RECORD,U,10)="",$P(RECORD,U,11)="",$P(RECORD,U,12)="" D
.... S AGFRMSG2=$S(CPTR="D":"DENTAL COVERAGE",CPTR="O":"OPTOMETRY COVERAGE",CPTR="R":"PHARMACY COVERAGE",CPTR="P":"MENTAL HEALTH COVERAGE",CPTR="A":"AUTO ACCIDENT/TORT COVERAGE",CPTR="W":"WORKMAN'S COMP COVERAGE",1:"MEDICAL COVERAGE")
.... S AGFRMMSG=$E(SQDT,4,5)_"/"_$E(SQDT,6,7)_"/"_($E(SQDT,1,3)+1700)
.... S INSPTR=$P(RECORD,U,3)
.... S AGREC=0
.... F S AGREC=$O(AGINS(AGREC)) Q:'AGREC D
..... S AGINSREC=$G(AGINS(AGREC))
..... I $P(AGINSREC,U,2)=INSPTR D
...... S INS=$P(AGINSREC,U,2)
...... S COV=$P(AGINSREC,U,4)
...... S EBEG=$P(AGINSREC,U,5)
...... S EEND=$P(AGINSREC,U,6)
...... S PHOLDER=$P(AGINSREC,U,7)
...... S POLNUM=$P(AGINSREC,U,9)
...... S PLANPTR=$P(AGINSREC,U,12)
...... S USER=$P(AGINSREC,U,13)
...... S RECPTR=$P(AGINSREC,U,14)
...... S AGCAT(CPTR,SEQEFDT,$P(RECORD,U,5))=INS_"^"_COV_"^"_EBEG_"^"_EEND_"^"_PHOLDER_"^"_POLNUM_"^"_SEQEFDT_"^"_PLANPTR_"^"_USER_"^"_ENTDAT_U_RECPTR
... E D
.... ;S CPTR=$P(RECORD,U,4) ;IHS/SD/AR AG*7.1*7 3/15/2010
.... S AGSEL=$P(RECORD,U,5)
.... ;I $P(RECORD,U,3)'="" S INS=$P(RECORD,U,3)
.... ;I $P(RECORD,U,3)="" S INS=3
.... S INS=$P(RECORD,U,3) ;IHS/SD/TPF AG*7.1*1 9/6/2005
.... ;S INS="" ;TESTING TPF
.... S COV=$P(RECORD,U,7)
.... S EBEG=$P(RECORD,U,8)
.... S EEND=$P(RECORD,U,9)
.... S PHOLDER=$P(RECORD,U,12)
.... S POLNUM=$P(RECORD,U,10)
.... S PLANPTR=$P(RECORD,U,11)
.... S USER=$P(RECORD,U,13)
.... S RECPTR=$P(RECORD,U,14)
.... S AGCAT(CPTR,SEQEFDT,AGSEL)=INS_"^"_COV_"^"_EBEG_"^"_EEND_"^"_PHOLDER_"^"_POLNUM_"^"_SEQEFDT_"^"_PLANPTR_"^"_USER_"^"_ENTDAT_U_RECPTR
Q
AGCAT ;IHS/SD/EFG - WORK WITH CATEGORY PRIORITIZING ; MAR 19, 2010
+1 ;;7.1;PATIENT REGISTRATION;**1,2,7**;AUG 25, 2005
+2 ;THIS ROUTINE WAS CREATED TO REMOVE THESE SUBROUTINES
+3 ;FROM ^AGED4A DUE TO ROUTINE SIZE RESTRICTIONS
+4 QUIT
BLDAGCAT ;EP - LOAD ARRAY "AGCAT" WITH SEQUENCED INSURERS
+1 KILL AGCAT(CATPTR,SEQEFDT)
+2 NEW AGSEL,AGI,AGC,INS,COV,RECPTR,EBEG,EEND,PHOLDER,POLNUM,ST,STPTR,PLANPTR
+3 SET AGSEL=0
+4 SET AGI=""
+5 FOR AGC=1:1
SET AGI=$PIECE(PRSEQ,",",AGC)
IF AGI=""
QUIT
Begin DoDot:1
+6 SET AGSEL=AGSEL+1
+7 SET INS=$PIECE(AGINS(AGI),U,2)
+8 SET COV=$PIECE(AGINS(AGI),U,4)
+9 SET EBEG=$PIECE(AGINS(AGI),U,5)
+10 SET EEND=$PIECE(AGINS(AGI),U,6)
+11 SET PHPTR=$PIECE(AGINS(AGI),U,7)
+12 SET POLNUM=$PIECE(AGINS(AGI),U,9)
+13 SET RECPTR=$PIECE(AGINS(AGI),U,11)
+14 SET PLANPTR=$PIECE(AGINS(AGI),U,12)
+15 ;S AGCAT(CATPTR,SEQEFDT,AGSEL)=INS_"^"_COV_"^"_EBEG_"^"_EEND_"^"_PHPTR_"^"_POLNUM_"^"_SEQEFDT_"^"_PLANPTR_U_RECPTR
+16 SET USER=DUZ
+17 SET AGCAT(CATPTR,SEQEFDT,AGSEL)=INS_"^"_COV_"^"_EBEG_"^"_EEND_"^"_PHPTR_"^"_POLNUM_"^"_SEQEFDT_"^"_PLANPTR_"^"_USER_"^"_DT_U_RECPTR
End DoDot:1
+18 ;"^"_USER_"^"_ENTDAT_U_RECPTR
+19 IF $DATA(^AUPNICP("EFF2",DFN,SEQEFDT,CATPTR))
DO DELICP
+20 QUIT
LOADICP ;EP - LOAD THE CATEGORY PRIORITIZING GLOBAL WITH WHAT
+1 ;THE USER CATEGORIZED AND SEQUENCED IN ARRAY "AGCAT"
+2 NEW AGA,AGDT,AGB,CATREC,EFFDT,PATIEN,X
+3 NEW INS,COV,EBEG,EEND,PHOLDER,POLNUM,ST,PLANPTR
+4 SET AGA=""
+5 ; AGA = CATEGORY
FOR
SET AGA=$ORDER(AGCAT(AGA))
IF AGA=""
QUIT
Begin DoDot:1
+6 SET AGDT=""
+7 ; AGDT = PRIORITY EFF DT
FOR
SET AGDT=$ORDER(AGCAT(AGA,AGDT))
IF AGDT=""
QUIT
Begin DoDot:2
+8 IF '$DATA(^AUPNICP("EFF2",DFN,AGDT,AGA))
Begin DoDot:3
+9 SET AGB=0
+10 ; AGB = SEQUENCE
FOR
SET AGB=$ORDER(AGCAT(AGA,AGDT,AGB))
IF 'AGB
QUIT
Begin DoDot:4
+11 SET CATREC=$GET(AGCAT(AGA,AGDT,AGB))
+12 ; ADD NEW RECORD TO AUPNICP
+13 SET INS=$PIECE(CATREC,U)
+14 SET COV=$PIECE(CATREC,U,2)
+15 SET EBEG=$PIECE(CATREC,U,3)
+16 SET EEND=$PIECE(CATREC,U,4)
+17 SET PHOLDER=$PIECE(CATREC,U,5)
+18 SET POLNUM=$PIECE(CATREC,U,6)
+19 SET EFFDT=$PIECE(CATREC,U,7)
+20 SET PLANPTR=$PIECE(CATREC,U,8)
+21 ;S RECPTR=$P(CATREC,U,9)
+22 SET RECPTR=$PIECE(CATREC,U,11)
+23 SET USER=DUZ
+24 SET PATIEN=DFN
+25 SET DIC="^AUPNICP("
+26 SET DIC(0)="L"
+27 SET DLAYGO=9000035
+28 SET DIC("DR")=".02////^S X=PATIEN"
+29 SET DIC("DR")=DIC("DR")_";.03////^S X=INS"
+30 SET DIC("DR")=DIC("DR")_";.04////^S X=AGA"
+31 SET DIC("DR")=DIC("DR")_";.05///^S X=AGB"
+32 SET DIC("DR")=DIC("DR")_";.06////^S X=EFFDT"
+33 SET DIC("DR")=DIC("DR")_";.07///^S X=COV"
+34 SET DIC("DR")=DIC("DR")_";.08////^S X=EBEG"
+35 SET DIC("DR")=DIC("DR")_";.09////^S X=EEND"
+36 SET DIC("DR")=DIC("DR")_";.11///^S X=POLNUM"
+37 SET DIC("DR")=DIC("DR")_";.12////^S X=PLANPTR"
+38 SET DIC("DR")=DIC("DR")_";.13///^S X=PHOLDER"
+39 ;S DIC("DR")=DIC("DR")_";.14///^S X=USER"
+40 ;AG*7.1*1 IM18549;IM8663
SET DIC("DR")=DIC("DR")_";.14////"_DUZ
+41 SET DIC("DR")=DIC("DR")_";.15///^S X=RECPTR"
+42 WRITE "."
+43 ;ED EXPLAINED THIS WAS IN HERE TO MAKE SURE EACH .01 ENTRY WAS A
HANG 1
+44 ;DATE TIME STAMP. HE WAS NOT SURE WHETHER IT WAS FOR FUTURE USE AND API OR
+45 ;OR AN IMMEDIATE NEED.
+46 DO NOW^%DTC
+47 SET X=%
+48 KILL DD,DO,DINUM
+49 DO FILE^DICN
+50 KILL DIC
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+51 QUIT
DELICP ;DELETE RE-CATEGORIZED RECORDS IN "^AUPNICP" BASED ON ARRAY "AGCAT"
+1 NEW AGB,DA
+2 SET AGB=0
+3 FOR
SET AGB=$ORDER(^AUPNICP("EFF2",DFN,SEQEFDT,CATPTR,AGB))
IF 'AGB
QUIT
Begin DoDot:1
+4 SET DA=AGB
+5 SET DIK="^AUPNICP("
+6 DO ^DIK
End DoDot:1
+7 QUIT
LOADCAT ;EP - FIND PATIENT'S RECORDS IN CATEGORY PRIORITIZING GLOBAL (AUPNICP)
+1 ;AND LOAD INTO ARRAY "AGCAT"
+2 NEW CPTR,SQDT,RECNO,RECORD,SEQEFDT,AGSEL,RECPTR
+3 NEW ST,INS,COV,EBEG,EEND,PHOLDER,POLNUM,PLANPTR
+4 ;IHS/SD/TPF 5/1/2006 AG*7.1*2 IM20494
KILL AGCAT
+5 SET CPTR=""
+6 FOR
SET CPTR=$ORDER(^AUPNICP("EFF",DFN,CPTR))
IF CPTR=""
QUIT
Begin DoDot:1
+7 SET SQDT=""
+8 FOR
SET SQDT=$ORDER(^AUPNICP("EFF",DFN,CPTR,SQDT))
IF 'SQDT
QUIT
Begin DoDot:2
+9 SET RECNO=0
+10 FOR
SET RECNO=$ORDER(^AUPNICP("EFF",DFN,CPTR,SQDT,RECNO))
IF 'RECNO
QUIT
Begin DoDot:3
+11 SET RECORD=$GET(^AUPNICP(RECNO,0))
+12 SET ENTDAT=$PIECE(RECORD,U)
+13 SET SEQEFDT=$PIECE(RECORD,U,6)
+14 IF $PIECE(RECORD,U,7)=""
IF $PIECE(RECORD,U,8)=""
IF $PIECE(RECORD,U,9)=""
IF $PIECE(RECORD,U,10)=""
IF $PIECE(RECORD,U,11)=""
IF $PIECE(RECORD,U,12)=""
Begin DoDot:4
+15 SET AGFRMSG2=$SELECT(CPTR="D":"DENTAL COVERAGE",CPTR="O":"OPTOMETRY COVERAGE",CPTR="R":"PHARMACY COVERAGE",CPTR="P":"MENTAL HEALTH COVERAGE",CPTR="A":"AUTO ACCIDENT/TORT COVERAGE",CPTR="W":"WO
RKMAN'S COMP COVERAGE",1:"MEDICAL COVERAGE")
+16 SET AGFRMMSG=$EXTRACT(SQDT,4,5)_"/"_$EXTRACT(SQDT,6,7)_"/"_($EXTRACT(SQDT,1,3)+1700)
+17 SET INSPTR=$PIECE(RECORD,U,3)
+18 SET AGREC=0
+19 FOR
SET AGREC=$ORDER(AGINS(AGREC))
IF 'AGREC
QUIT
Begin DoDot:5
+20 SET AGINSREC=$GET(AGINS(AGREC))
+21 IF $PIECE(AGINSREC,U,2)=INSPTR
Begin DoDot:6
+22 SET INS=$PIECE(AGINSREC,U,2)
+23 SET COV=$PIECE(AGINSREC,U,4)
+24 SET EBEG=$PIECE(AGINSREC,U,5)
+25 SET EEND=$PIECE(AGINSREC,U,6)
+26 SET PHOLDER=$PIECE(AGINSREC,U,7)
+27 SET POLNUM=$PIECE(AGINSREC,U,9)
+28 SET PLANPTR=$PIECE(AGINSREC,U,12)
+29 SET USER=$PIECE(AGINSREC,U,13)
+30 SET RECPTR=$PIECE(AGINSREC,U,14)
+31 SET AGCAT(CPTR,SEQEFDT,$PIECE(RECORD,U,5))=INS_"^"_COV_"^"_EBEG_"^"_EEND_"^"_PHOLDER_"^"_POLNUM_"^"_SEQEFDT_"^"_PLANPTR_"^"_USER_"^"_ENTDAT_U_RECPTR
End DoDot:6
End DoDot:5
End DoDot:4
+32 IF '$TEST
Begin DoDot:4
+33 ;S CPTR=$P(RECORD,U,4) ;IHS/SD/AR AG*7.1*7 3/15/2010
+34 SET AGSEL=$PIECE(RECORD,U,5)
+35 ;I $P(RECORD,U,3)'="" S INS=$P(RECORD,U,3)
+36 ;I $P(RECORD,U,3)="" S INS=3
+37 ;IHS/SD/TPF AG*7.1*1 9/6/2005
SET INS=$PIECE(RECORD,U,3)
+38 ;S INS="" ;TESTING TPF
+39 SET COV=$PIECE(RECORD,U,7)
+40 SET EBEG=$PIECE(RECORD,U,8)
+41 SET EEND=$PIECE(RECORD,U,9)
+42 SET PHOLDER=$PIECE(RECORD,U,12)
+43 SET POLNUM=$PIECE(RECORD,U,10)
+44 SET PLANPTR=$PIECE(RECORD,U,11)
+45 SET USER=$PIECE(RECORD,U,13)
+46 SET RECPTR=$PIECE(RECORD,U,14)
+47 SET AGCAT(CPTR,SEQEFDT,AGSEL)=INS_"^"_COV_"^"_EBEG_"^"_EEND_"^"_PHOLDER_"^"_POLNUM_"^"_SEQEFDT_"^"_PLANPTR_"^"_USER_"^"_ENTDAT_U_RECPTR
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+48 QUIT
