- 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
