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
