- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSC02.m
r613 r623 1 IBCNSC02 2 ;;2.0;INTEGRATED BILLING;**320,371**;21-MAR-94;Build 57 3 ;;Per VHA Directive 2004-038, this routine should not be modified.4 5 6 7 DISP 8 9 10 11 12 13 S (START,IBLINE)=62 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 DISPX 54 55 56 57 58 59 60 PARENT(IBCNS) 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 PARENTX 78 79 80 HDR 81 82 83 84 HDRX 85 86 87 BLD 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 BLDX 123 124 125 LINK 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 LINKX 175 176 177 178 UNLINK 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 UNLINKX 209 210 211 212 PCNT(Z) 213 214 215 216 217 218 INSADD(Z) 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 INSADDX 236 237 238 INSCO(Z) 239 240 241 242 243 244 INSCOX 245 246 247 INSLIST(INS) 248 249 250 251 252 INSLISTX 253 254 1 IBCNSC02 ;ALB/ESG - Insurance Company parent/child management ;01-NOV-2005 2 ;;2.0;INTEGRATED BILLING;**320**;21-MAR-1994 3 ;;Per VHA Directive 10-93-142, this routine should not be modified. 4 ; 5 Q 6 ; 7 DISP ; entry point for display of parent/child companies 8 NEW PCFLG,PARENT,PCDESC,TITLE,START,IBLINE,OFFSET,INSDATA,CNT,TXT 9 S PCFLG=$P($G(^DIC(36,+IBCNS,3)),U,13),PARENT="" 10 I PCFLG="C" S PARENT=$P($G(^DIC(36,+IBCNS,3)),U,14),PCDESC="Child" 11 I PCFLG="P" S PCDESC="Parent" 12 S TITLE=" Associated Insurance Companies " 13 S (START,IBLINE)=54 14 S OFFSET=(40-($L(TITLE)/2))\1+1 15 D SET^IBCNSP(START,OFFSET,TITLE,IORVON,IORVOFF) 16 ; 17 ; no link - display this and get out 18 I PCFLG="" D G DISPX 19 . S IBLINE=IBLINE+1 20 . D SET^IBCNSP(IBLINE,3,"This insurance company is not defined as either a Parent or a Child.") 21 . Q 22 ; 23 ; display for either parent or child 24 S IBLINE=IBLINE+1 25 D SET^IBCNSP(IBLINE,3,"This insurance company is defined as a "_PCDESC_" Insurance Company.") 26 ; 27 ; child display 28 I PCFLG="C" D G DISPX 29 . S IBLINE=IBLINE+1 30 . D SET^IBCNSP(IBLINE,3,"It is associated with the following Parent Insurance Company:") 31 . S IBLINE=IBLINE+1 32 . D SET^IBCNSP(IBLINE,2," ") ; blank line 33 . S INSDATA="" 34 . I 'PARENT S INSDATA="*** Parent Insurance Company not defined ***" 35 . I PARENT D 36 .. N AD S AD=$$INSADD(PARENT) ; get parent ins co data 37 .. S INSDATA=$P(AD,U,1)_" "_$P(AD,U,2)_" "_$P(AD,U,6) 38 .. Q 39 . S IBLINE=IBLINE+1 40 . D SET^IBCNSP(IBLINE,8,INSDATA) 41 . Q 42 ; 43 ; parent display 44 S CNT=$$PCNT(IBCNS) ; count # of children 45 S TXT="There are "_CNT_" Child Insurance Companies" 46 I CNT=1 S TXT="There is 1 Child Insurance Company" 47 S TXT=TXT_" associated with it." 48 S IBLINE=IBLINE+1 49 D SET^IBCNSP(IBLINE,3,TXT) 50 S IBLINE=IBLINE+1 51 D SET^IBCNSP(IBLINE,3,"Select the ""AC Associate Companies"" action to enter/edit the children.") 52 ; 53 DISPX ; end with 2 blank lines 54 S IBLINE=IBLINE+1 55 D SET^IBCNSP(IBLINE,2," ") ; blank line 56 S IBLINE=IBLINE+1 57 D SET^IBCNSP(IBLINE,2," ") ; blank line 58 Q 59 ; 60 PARENT(IBCNS) ; Insurance company parent/child management 61 ; Calls ListMan screen for parent insurance companies 62 NEW PCFLG 63 I '$G(IBCNS) G PARENTX 64 S PCFLG=$P($G(^DIC(36,IBCNS,3)),U,13) 65 ; 66 ; special check to remove 3.13 field if 3.14 field is nil 67 I PCFLG="C",'$P($G(^DIC(36,IBCNS,3)),U,14) D 68 . N DIE,DA,DR S DIE=36,DA=IBCNS,DR="3.13////@" D ^DIE 69 . Q 70 ; 71 ; get out if not a parent insurance company 72 I PCFLG'="P" G PARENTX 73 ; 74 ; call ListMan for parent/children management 75 D EN^VALM("IBCNS ASSOCIATIONS LIST") 76 KILL ^TMP($J,"IBCNSL") 77 PARENTX ; 78 Q 79 ; 80 HDR ; List header info 81 S VALMHDR(1)="Parent Insurance Company:" 82 S VALMHDR(2)=" "_$$INSCO(IBCNS) 83 S VALMHDR(3)="" 84 HDRX ; 85 Q 86 ; 87 BLD ; Build list contents 88 NEW C,INSDATA,INSNAME,STCITY,ENTRY,NM,ST,IEN,X 89 KILL ^TMP($J,"IBCNSL") 90 S C=0 91 F S C=$O(^DIC(36,"APC",IBCNS,C)) Q:'C D 92 . S INSDATA=$$INSADD(C) 93 . S INSNAME=$P(INSDATA,U,1) 94 . I INSNAME="" S INSNAME="~UNKNOWN" 95 . S STCITY=$P(INSDATA,U,7) 96 . I STCITY="" S STCITY="~UNKNOWN" 97 . S ^TMP($J,"IBCNSL",1,INSNAME,STCITY,C)="" 98 . Q 99 ; 100 I '$D(^TMP($J,"IBCNSL",1)) D G BLDX 101 . ; no children insurance companies found 102 . S ^TMP($J,"IBCNSL",2,1,0)="" 103 . S ^TMP($J,"IBCNSL",2,2,0)=" No Children Insurance Companies Found" 104 . S VALMCNT=2 105 . Q 106 ; 107 S VALMCNT=0,ENTRY=0 108 S NM="" 109 F S NM=$O(^TMP($J,"IBCNSL",1,NM)) Q:NM="" D 110 . S ST="" 111 . F S ST=$O(^TMP($J,"IBCNSL",1,NM,ST)) Q:ST="" D 112 .. S IEN=0 113 .. F S IEN=$O(^TMP($J,"IBCNSL",1,NM,ST,IEN)) Q:'IEN D 114 ... S VALMCNT=VALMCNT+1,ENTRY=ENTRY+1 115 ... S X=$$FO^IBCNEUT1($J(ENTRY,3),5)_$$INSCO(IEN) 116 ... S ^TMP($J,"IBCNSL",2,VALMCNT,0)=X 117 ... S ^TMP($J,"IBCNSL",2,"IDX",VALMCNT,ENTRY)="" 118 ... S ^TMP($J,"IBCNSL",3,ENTRY)=IEN_U_VALMCNT 119 ... Q 120 .. Q 121 . Q 122 BLDX ; 123 Q 124 ; 125 LINK ; action protocol IBCNSL LINK used to associate children insurance 126 ; companies to the current parent ins co for the list 127 NEW DIC,X,Y,DIE,DR,DA,NEWINS,IBSTOP,PAR,DIR,DIRUT,DTOUT,DUOUT,DIROUT 128 D FULL^VALM1 129 I '$$KCHK^XUSRB("IB EDI INSURANCE EDIT") D G LINKX 130 . W !!?5,"You must hold the IB EDI INSURANCE EDIT key to access this option." 131 . D PAUSE^VALM1 132 . Q 133 ; 134 ; lookup ins company 135 W ! 136 S DIC=36,DIC(0)="AEMQ",DIC("A")="Select Insurance Company: " 137 S DIC("W")="D INSLIST^IBCNSC02(Y)" 138 ; screen - ins co Y is not a parent and also it is not already in the list of children 139 S DIC("S")="I $P($G(^DIC(36,Y,3)),U,13)'=""P""&'$D(^DIC(36,""APC"",IBCNS,Y))" 140 D ^DIC K DIC 141 I +Y'>0 G LINKX 142 S NEWINS=+Y 143 ; 144 ; check to see if this selected insurance company is already a child 145 ; for some other parent 146 S PAR=+$P($G(^DIC(36,NEWINS,3)),U,14),IBSTOP=0 147 I PAR,PAR'=IBCNS D 148 . W ! 149 . S DIR(0)="YO",DIR("B")="No" 150 . S DIR("A",1)="Please Note: The insurance company you selected is currently identified" 151 . S DIR("A",2)="as a Child insurance company associated with the following Parent:" 152 . S DIR("A",3)="" 153 . S DIR("A",4)=" "_$$INSCO(PAR) 154 . S DIR("A",5)="" 155 . S DIR("A")="OK to proceed and make this switch" 156 . D ^DIR K DIR 157 . I Y'=1 S IBSTOP=1 Q 158 . Q 159 I IBSTOP G LINKX 160 ; 161 ; lock the potential new child ins company 162 L +^DIC(36,NEWINS):0 I '$T D LOCKED^IBTRCD1 G LINKX 163 ; 164 ; update selected child 165 S DIE=36,DA=NEWINS,DR="3.13////C;3.14////"_IBCNS D ^DIE 166 ; 167 ; Copy the IDs from the parent 168 D COPY^IBCEPCID(NEWINS) 169 ; 170 ; unlock 171 L -^DIC(36,NEWINS) 172 ; 173 D BLD ; rebuild list of children 174 LINKX ; 175 S VALMBCK="R" 176 Q 177 ; 178 UNLINK ; action protocol IBCNSL UNLINK used to disassociate selected children 179 ; insurance companies from the list. 180 NEW DIR,X,Y,DIRUT,DTOUT,DUOUT,DIROUT,IBLST,IBSUB,IBPCE,IBSEL,DA,DIE,DR 181 D FULL^VALM1 182 I '$$KCHK^XUSRB("IB EDI INSURANCE EDIT") D G UNLINKX 183 . W !!?5,"You must hold the IB EDI INSURANCE EDIT key to access this option." 184 . D PAUSE^VALM1 185 . Q 186 ; 187 I '$D(^TMP($J,"IBCNSL",3)) D G UNLINKX 188 . W !!?5,"There are no insurance companies to select." D PAUSE^VALM1 189 . Q 190 S DIR(0)="LO^1:"_+$O(^TMP($J,"IBCNSL",3,""),-1) 191 S DIR("A")="Select Insurance Company(s)" 192 W ! D ^DIR K DIR 193 I $D(DIRUT) G UNLINKX 194 M IBLST=Y 195 ; 196 W ! 197 S DIR(0)="YO" 198 S DIR("A")="OK to proceed",DIR("B")="No" 199 D ^DIR K DIR 200 I Y'=1 G UNLINKX 201 ; 202 F IBSUB=0:1 Q:'$D(IBLST(IBSUB)) F IBPCE=1:1 S IBSEL=$P(IBLST(IBSUB),",",IBPCE) Q:'IBSEL D 203 . S DA=+$G(^TMP($J,"IBCNSL",3,IBSEL)) I 'DA Q 204 . S DIE=36,DR="3.13////@;3.14////@" D ^DIE 205 . Q 206 ; 207 D BLD ; rebuild list of children 208 UNLINKX ; 209 S VALMBCK="R" 210 Q 211 ; 212 PCNT(Z) ; count number of children for parent ins co Z 213 NEW C,CNT 214 S C=0,Z=+$G(Z) 215 F CNT=0:1 S C=$O(^DIC(36,"APC",Z,C)) Q:'C 216 Q CNT 217 ; 218 INSADD(Z) ; function to return ins co address components 219 NEW INSDATA,AD,NM,L1,CITY,ST,ZIP,CITYST,STCITY 220 S INSDATA="" 221 S AD=$G(^DIC(36,+$G(Z),.11)) 222 S NM=$P($G(^DIC(36,Z,0)),U,1) 223 S L1=$P(AD,U,1),CITY=$P(AD,U,4),ST=$P(AD,U,5),ZIP=$P(AD,U,6) 224 I ST S ST=$P($G(^DIC(5,ST,0)),U,2) 225 S CITYST=$E(CITY,1,15)_" "_ST 226 I CITY'="",ST'="" S CITYST=$E(CITY,1,15)_","_ST 227 ; 228 S $P(STCITY,"|",1)=ST 229 I ST="" S $P(STCITY,"|",1)="~~" 230 S $P(STCITY,"|",2)=CITY 231 I CITY="" S $P(STCITY,"|",2)="~~~~" 232 ; 233 S INSDATA=NM_U_L1_U_CITY_U_ST_U_ZIP_U_CITYST_U_STCITY 234 ; 1 2 3 4 5 6 7 235 INSADDX ; 236 Q INSDATA 237 ; 238 INSCO(Z) ; return display data for ins co Z 239 NEW X,Y 240 S Y=$$INSADD(Z) 241 S X=$$FO^IBCNEUT1($P(Y,U,1),27) 242 S X=X_$$FO^IBCNEUT1($P(Y,U,2),26) 243 S X=X_$$FO^IBCNEUT1($P(Y,U,6),18) 244 INSCOX ; 245 Q X 246 ; 247 INSLIST(INS) ; insurance company lister for ^DIC call 248 NEW Z 249 S Z=$$INSADD(INS) 250 W ?27,$E($P(Z,U,2),1,20) ; address line 1 251 W ?47," ",$P(Z,U,6) ; city, state 252 INSLISTX ; 253 Q 254 ;
Note:
See TracChangeset
for help on using the changeset viewer.
