- VENPCCG1 ; IHS/OIT/GIS - GET ICD PREFERENCES: SORTER ;
- ;;2.6;PCC+;;NOV 12, 2007
- ;
- ;
- ;
- ST ; EP - CALLED FROM VENPCCG AND VENPCC1
- I '$G(QUIET) D ^XBCLS
- ;
- MSG ;
- I '$G(NEWDXP) U 0 W !!,"Building Temp file. Please hold......"
- E I '$G(QUIET) W !!,"Searching database for preferences..."
- ;
- S ED=ED_".9999"
- S VD=BD-1
- F S VD=$O(^AUPNVSIT("B",VD)) Q:VD="" D
- . S VDFN=0 F S VDFN=$O(^AUPNVSIT("B",VD,VDFN)) Q:VDFN="" D
- ..I $G(VENDEPT) S %=$P($G(^AUPNVSIT(VDFN,0)),U,8) I VENDEPT'=% Q
- ..I TYPE'="A" D SCREEN I FL="N" Q
- ..D PAT Q:DOB="" Q:PAT=""
- .. S Z=0 F S Z=$O(^AUPNVPOV("AD",VDFN,Z)) Q:'Z D
- ... S REC=^AUPNVPOV(Z,0)
- ... S ICD=$P(REC,"^",1)
- ... S PNP=$P(REC,"^",4) ;dmh added 8/31/2000 to get prov. narr.
- ...I AGE<18 S AGEGRP=1
- ...E S AGEGRP=2
- ...D AGEGRPS
- ...;S @TMP@("VPOV",AGEGRP,SEX,CLIN,ICD)=$G(@TMP@("VPOV",AGEGRP,SEX,CLIN,ICD))+1
- ... S @TMP@("VPOV",ICD,"B",AGEGRP)=$G(@TMP@("VPOV",ICD,"B",AGEGRP))+1 ;8/11
- ... S @TMP@("VPOV",ICD)=$G(@TMP@("VPOV",ICD))+1 ;8/11
- ... S @TMP@("VPOV",ICD,AP)=$G(@TMP@("VPOV",ICD,AP))+1 ;8/11
- ... ;the AP IS age group piece
- ...;
- ...;
- ...I PNP'="" S @TMP@("VPOV","PN",ICD,PNP)=$G(@TMP@("VPOV","PN",ICD,PNP))+1 ;8/31 ;not splitting out by age-sex grouping... just lumping all together
- ...;
- ...;
- G EXIT
- Q
- EXIT ;CLEANUP
- ;D NEXT
- I '$G(NEWDXP) D ^%ZISC
- K X,Y,Z,REC,CPT,VREC,CL,CT,CODE,CLIN,VEN,DPT0,DOS,VENPRV,VENGBL
- Q
- PAT ;
- S VIS=^AUPNVSIT(VDFN,0)
- S PAT=$P(VIS,"^",5)
- Q:PAT=""
- S CLIN=$P(VIS,"^",8)
- I CLIN="" S CLIN="OTHER"
- E D
- .S CC=$P($G(^DIC(40.7,CLIN,0)),"^",2)
- .I (CC=30)!(CC=80) S CLIN="ER"
- .E S CLIN="OTHER"
- S DOS=$P(VIS,"^",1),DOS=$P(DOS,".",1)
- S DPT0=$G(^DPT(PAT,0))
- S DOB=$P(DPT0,"^",3) Q:DOB=""
- S SEX=$P(DPT0,"^",2)
- I SEX="" S SEX="U"
- S X1=DOS,X2=DOB D ^%DTC S AGE=X\365.25
- Q
- SCREEN ;
- S FL="N"
- S VEN=0
- S %=$C(68)_"IC(6,",VENGBL=$S($G(^DD(9000010.06,.01,0))[%:(U_%_"VENPRV,0)"),1:"^VA(200,VENPRV,""PS"")")
- F S VEN=$O(^AUPNVPRV("AD",VDFN,VEN)) Q:VEN="" D Q:FL="Y"
- .I TYPE="P" D
- .. S VENPRV=$P($G(^AUPNVPRV(VEN,0)),"^",1)
- ..I VENPRV'="" I $D(VEN("PRV",VENPRV)) S FL="Y" Q
- ..;I $P($G(^AUPNVPRV(VEN,0)),"^",1)=VEN("PRV") S FL="Y"
- ..Q
- .I TYPE="C" D
- .. S VENPRV=$P($G(^AUPNVPRV(VEN,0)),"^",1)
- .. S VENPTY=$S(VENGBL[200:$P($G(@VENGBL),U,5),1:$P($G(@VENGBL),U,4))
- ..I VENPTY'="",$D(VEN("PC",VENPTY)) S FL="Y"
- ..Q
- Q
- AGEGRPS ;
- ; AP will be the age group node that will be used in extraction
- I (AGE<3) S AP=1 Q
- I (AGE>2),(AGE<13) S AP=2 Q
- I (AGE>12),(AGE<18),(SEX="M") S AP=3 Q
- I (AGE>12),(AGE<18),(SEX="F") S AP=4 Q
- I (AGE>17),(AGE<65),(SEX="M") S AP=5 Q
- I (AGE>17),(AGE<65),(SEX="F") S AP=6 Q
- I (AGE>64),(SEX="M") S AP=7 Q
- I (AGE>64),(SEX="F") S AP=8 Q
- Q
- VENPCCG1 ; IHS/OIT/GIS - GET ICD PREFERENCES: SORTER ;
- +1 ;;2.6;PCC+;;NOV 12, 2007
- +2 ;
- +3 ;
- +4 ;
- ST ; EP - CALLED FROM VENPCCG AND VENPCC1
- +1 IF '$GET(QUIET)
- DO ^XBCLS
- +2 ;
- MSG ;
- +1 IF '$GET(NEWDXP)
- USE 0
- WRITE !!,"Building Temp file. Please hold......"
- +2 IF '$TEST
- IF '$GET(QUIET)
- WRITE !!,"Searching database for preferences..."
- +3 ;
- +4 SET ED=ED_".9999"
- +5 SET VD=BD-1
- +6 FOR
- SET VD=$ORDER(^AUPNVSIT("B",VD))
- IF VD=""
- QUIT
- Begin DoDot:1
- +7 SET VDFN=0
- FOR
- SET VDFN=$ORDER(^AUPNVSIT("B",VD,VDFN))
- IF VDFN=""
- QUIT
- Begin DoDot:2
- +8 IF $GET(VENDEPT)
- SET %=$PIECE($GET(^AUPNVSIT(VDFN,0)),U,8)
- IF VENDEPT'=%
- QUIT
- +9 IF TYPE'="A"
- DO SCREEN
- IF FL="N"
- QUIT
- +10 DO PAT
- IF DOB=""
- QUIT
- IF PAT=""
- QUIT
- +11 SET Z=0
- FOR
- SET Z=$ORDER(^AUPNVPOV("AD",VDFN,Z))
- IF 'Z
- QUIT
- Begin DoDot:3
- +12 SET REC=^AUPNVPOV(Z,0)
- +13 SET ICD=$PIECE(REC,"^",1)
- +14 ;dmh added 8/31/2000 to get prov. narr.
- SET PNP=$PIECE(REC,"^",4)
- +15 IF AGE<18
- SET AGEGRP=1
- +16 IF '$TEST
- SET AGEGRP=2
- +17 DO AGEGRPS
- +18 ;S @TMP@("VPOV",AGEGRP,SEX,CLIN,ICD)=$G(@TMP@("VPOV",AGEGRP,SEX,CLIN,ICD))+1
- +19 ;8/11
- SET @TMP@("VPOV",ICD,"B",AGEGRP)=$GET(@TMP@("VPOV",ICD,"B",AGEGRP))+1
- +20 ;8/11
- SET @TMP@("VPOV",ICD)=$GET(@TMP@("VPOV",ICD))+1
- +21 ;8/11
- SET @TMP@("VPOV",ICD,AP)=$GET(@TMP@("VPOV",ICD,AP))+1
- +22 ;the AP IS age group piece
- +23 ;
- +24 ;
- +25 ;8/31 ;not splitting out by age-sex grouping... just lumping all together
- IF PNP'=""
- SET @TMP@("VPOV","PN",ICD,PNP)=$GET(@TMP@("VPOV","PN",ICD,PNP))+1
- +26 ;
- +27 ;
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +28 GOTO EXIT
- +29 QUIT
- EXIT ;CLEANUP
- +1 ;D NEXT
- +2 IF '$GET(NEWDXP)
- DO ^%ZISC
- +3 KILL X,Y,Z,REC,CPT,VREC,CL,CT,CODE,CLIN,VEN,DPT0,DOS,VENPRV,VENGBL
- +4 QUIT
- PAT ;
- +1 SET VIS=^AUPNVSIT(VDFN,0)
- +2 SET PAT=$PIECE(VIS,"^",5)
- +3 IF PAT=""
- QUIT
- +4 SET CLIN=$PIECE(VIS,"^",8)
- +5 IF CLIN=""
- SET CLIN="OTHER"
- +6 IF '$TEST
- Begin DoDot:1
- +7 SET CC=$PIECE($GET(^DIC(40.7,CLIN,0)),"^",2)
- +8 IF (CC=30)!(CC=80)
- SET CLIN="ER"
- +9 IF '$TEST
- SET CLIN="OTHER"
- End DoDot:1
- +10 SET DOS=$PIECE(VIS,"^",1)
- SET DOS=$PIECE(DOS,".",1)
- +11 SET DPT0=$GET(^DPT(PAT,0))
- +12 SET DOB=$PIECE(DPT0,"^",3)
- IF DOB=""
- QUIT
- +13 SET SEX=$PIECE(DPT0,"^",2)
- +14 IF SEX=""
- SET SEX="U"
- +15 SET X1=DOS
- SET X2=DOB
- DO ^%DTC
- SET AGE=X\365.25
- +16 QUIT
- SCREEN ;
- +1 SET FL="N"
- +2 SET VEN=0
- +3 SET %=$CHAR(68)_"IC(6,"
- SET VENGBL=$SELECT($GET(^DD(9000010.06,.01,0))[%:(U_%_"VENPRV,0)"),1:"^VA(200,VENPRV,""PS"")")
- +4 FOR
- SET VEN=$ORDER(^AUPNVPRV("AD",VDFN,VEN))
- IF VEN=""
- QUIT
- Begin DoDot:1
- +5 IF TYPE="P"
- Begin DoDot:2
- +6 SET VENPRV=$PIECE($GET(^AUPNVPRV(VEN,0)),"^",1)
- +7 IF VENPRV'=""
- IF $DATA(VEN("PRV",VENPRV))
- SET FL="Y"
- QUIT
- +8 ;I $P($G(^AUPNVPRV(VEN,0)),"^",1)=VEN("PRV") S FL="Y"
- +9 QUIT
- End DoDot:2
- +10 IF TYPE="C"
- Begin DoDot:2
- +11 SET VENPRV=$PIECE($GET(^AUPNVPRV(VEN,0)),"^",1)
- +12 SET VENPTY=$SELECT(VENGBL[200:$PIECE($GET(@VENGBL),U,5),1:$PIECE($GET(@VENGBL),U,4))
- +13 IF VENPTY'=""
- IF $DATA(VEN("PC",VENPTY))
- SET FL="Y"
- +14 QUIT
- End DoDot:2
- End DoDot:1
- IF FL="Y"
- QUIT
- +15 QUIT
- AGEGRPS ;
- +1 ; AP will be the age group node that will be used in extraction
- +2 IF (AGE<3)
- SET AP=1
- QUIT
- +3 IF (AGE>2)
- IF (AGE<13)
- SET AP=2
- QUIT
- +4 IF (AGE>12)
- IF (AGE<18)
- IF (SEX="M")
- SET AP=3
- QUIT
- +5 IF (AGE>12)
- IF (AGE<18)
- IF (SEX="F")
- SET AP=4
- QUIT
- +6 IF (AGE>17)
- IF (AGE<65)
- IF (SEX="M")
- SET AP=5
- QUIT
- +7 IF (AGE>17)
- IF (AGE<65)
- IF (SEX="F")
- SET AP=6
- QUIT
- +8 IF (AGE>64)
- IF (SEX="M")
- SET AP=7
- QUIT
- +9 IF (AGE>64)
- IF (SEX="F")
- SET AP=8
- QUIT
- +10 QUIT
