VENPCCQA ; IHS/OIT/GIS - PRE INSTALL ; HS COMPONENT
;;2.6;PCC+;**1,2,3**;APR 03, 2012;Build 24
APCHS6B ; IHS/TUCSON/LAB - PART 6 OF APCHS -- SUMMARY PRODUCTION COMPONENTS
;;2.0;IHS RPMS/PCC Health Summary;;JUN 24, 1997
;
; D PEFLUSH(.OUT,"71270|5|10|2|2524\2528\2539") W ! ZW TOPIC Q
; S AGE=60,SEX="M",LINE=0,DFN=1,SEGIEN=-1 F CATIEN=10:1:26 D KBI(CATIEN)
Q
;
WCE ; ******************** WELL CHILD EXAM * 9000010 *******
N LINE,ARR
; <SETUP>
X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
; <DISPLAY>
D WCESEG(APCHSPAT) ; CREATE THE DISPLAY ARRAY
D PRINT ; PRINT THE SEGMENT
; <CLEANUP>
CLEANUP K APCHSDFN,APCHSN,APCHSICD,APCHSDAT,APCHSNRQ,APCHSICL
Q
;
LINE(STG) ; EP-CREATE A LINE IN THE SEGMENT
S LINE=LINE+1
S LINE(LINE)=STG
Q
;
PRINT ; EP-PRINT RESULTS
N CNT
S CNT=0
F S CNT=$O(LINE(CNT)) Q:'CNT D I $D(APCHSQIT) Q
. W !
. X APCHSCKP Q:$D(APCHSQIT)
. S X=LINE(CNT)
. W X
. Q
Q
;
WCESEG(DFN) ; EP - PRINT ALL WELL CHILD REMINDERS AND LAST RESULTS
N STG,SEX,AM,DAGE,MOM,X,SEGIEN,DAYS
S LINE=0
S STG=$G(^DPT(+$G(DFN),0)) I '$L(STG) Q ; INVALID DFN
S SEX=$S($P(STG,U,2)="M":"Male",$P(STG,U,2)="F":"Female",1:"") ; SEX
S MOM=$P($G(^DPT(DFN,.24)),U,2)
I MOM="" S MOM=$P($G(^DPT(DFN,.24)),U,3)
I MOM="" S MOM="??"
S AM=$$AM(DFN,.DAYS)
I AM="" Q ; AGE IN MONTHS ; PATCHED BY GIS 5/7/07
I 'DAYS S DAYS=1
S DAGE=$$DAGE(AM) I '$L(DAGE) Q ; DISPLAY AGE
S X=SEX_" "_DAGE_" Mother: "_MOM D LINE(X) ; INTRO DATA LINE
I '$L($G(APCHSEGH)) Q ; SEGMENT NAME MUST EXIST
I APCHSEGH="BYPASS" S SEGIEN=0
E S SEGIEN=$O(^APCHSCMP("B",$G(APCHSEGH),0)) I 'SEGIEN Q ; SEMENT IEN
WCE1 D REM(DFN,SEGIEN,SEX,DAYS) ; GET REMINDERS FOR EA KB CATEGORY
D LINE(" ")
Q
;
REM(DFN,SEGIEN,SEX,DAYS) ; EP - REMINDERS
N CATIEN,KBIEN,CAT,K,HDR,AGE,ARR,X,CNT,TOT,STG,ORD,CIEN,KTYPE,KIEN,MOD,PEIEN
N START,STOP,TITLE,TOT,DOM,ORD,DNAME,DORD,D
S AGE=$G(DAYS) I 'AGE Q
S SEX=$E(SEX) ; SCREEN BY SEX
S DOM=0
F S DOM=$O(^VEN(7.13,DOM)) Q:'DOM D
. S %=$G(^VEN(7.13,DOM,0)) I '$L(%) Q
. I '$P(%,U,7) Q ; SKIP INACTIVE DOMAINE
. S DNAME=$P(%,U)
. S DORD=$P(%,U,5)
. I 'DORD S DORD=100+(DOM*5)
. S CAT=0
. F S CAT=$O(^VEN(7.13,DOM,1,CAT)) Q:'CAT D ; CREATE THE ORDINAL ARRAY
.. S %=$G(^VEN(7.13,DOM,1,CAT,0))
.. S CATIEN=+% I 'CATIEN Q
.. S ORD=$P(%,U,2)
.. I 'ORD S ORD=100+CAT ; MAKE SURE EVERY CAT HAS AN ORDER - EVEN IF ONE IS NOT OFFICIALLY ASSIGNED
.. S ORD(DORD,ORD)=CATIEN
.. Q
. Q
S DORD=0
F S DORD=$O(ORD(DORD)) Q:'DORD D
. S ORD=0
. F S ORD=$O(ORD(DORD,ORD)) Q:'ORD S CATIEN=ORD(DORD,ORD) D KBI(CATIEN)
. Q
Q
;
KBI(CATIEN) ; EP - GET KB ITEMS
N LASTLINE,ARR
S K=$G(^VEN(7.11,CATIEN,0)) I '$L(K) Q
S HDR=$P(K,U,9) ; CATEGORY HEADER
S KTYPE=$P(K,U,11) ; TYPE OF KB ITEM: PT ED, DEVEL, SCREENING, ETC.
D LINE(" "),LINE(HDR) ; SET THE SPACER AND HEADER LINES FOR THIS CATEGORY OF ITEMS
S LASTLINE=LINE
S KIEN=0,TOT=0 K ARR
F S KIEN=$O(^VEN(7.12,"B",CATIEN,KIEN)) Q:'KIEN D ; CHECK EA. ENTRY IN THE KNOWLEDGE CATEGORY
. S STG=$G(^VEN(7.12,KIEN,0)) I '$L(STG) Q
. I $P(STG,U,11) Q ; INACTIVE ITEM
. S START=$P(STG,U,5) I AGE<START Q
. S STOP=$P(STG,U,6) I AGE>STOP Q
. S %=$P(STG,U,10) I $L(%),%'=SEX Q
. S TITLE=$P(STG,U,2) I '$L(TITLE) Q
. S MOD=$P(STG,U,12)
. I $L(MOD) S TITLE=TITLE_" ("_MOD_")"
. I MOD,KTYPE=2 S ARR(MOD)="__ "_TITLE Q ; STORE DEV ITEM LINES IN TEMP ARRAY FOR SORTING AND QUIT HERE
. ; PROCEED IF SECONDARY SORTING IS NOT REQUIRED
. S TOT(CATIEN)=$G(TOT(CATIEN))+1
. I $L($T(LAST^VENPCCK)) D LAST^VENPCCK(CATIEN,KIEN,DFN,.TITLE)
. S X="__ "_TOT(CATIEN)_". "_TITLE
. I $G(SEGIEN)=-1 S X=X_"|"_KIEN ; HIJACKED PROCESS SO APPEND ITEM IEN
. D LINE(X) ; SET THE ITEM NODE
. Q
I $D(ARR) D ; SORT BY %ILE
. S MOD=999
. F S MOD=$O(ARR(MOD),-1) Q:MOD="" S X=ARR(MOD) D LINE(X)
. K ARR
. Q
NOITEMS I LINE'=LASTLINE Q
S LINE=LINE-2
K LINE(LINE+1),LINE(LINE+2) ; NOTHING FOUND UNDER THIS KB CATEGORY SO REMOVER CAT HEADER
Q
;
AM(DFN,DAYS) ; EP - GIVEN A DFN, RETURN THE PTS CURRENT AGE IN MONTHS
N DOB,DIFF,MD,YD,DD,M
S DOB=$P($G(^DPT(DFN,0)),U,3) I 'DOB Q ""
I DOB>DT Q "" ; INVALID DOB
S (DAYS,D)=$$FMDIFF^XLFDT(DT,DOB,1)
I D<8 Q 0
I D<15 Q .25
I D<22 Q .5
I D<29 Q .75
S YD=$E(DT,1,3)-$E(DOB,1,3)
S MD=$E(DT,4,5)-$E(DOB,4,5)
S DD=$E(DT,6,7)-$E(DOB,6,7)
I DD<0 S MD=MD-1
I MD<1 S MD=MD+12,YD=YD-1
S M=MD+(YD*12)
I M<2 Q 1
Q M
;
DAGE(AM) ; EP - GIVEN AN AGE IN MONTHS, RETURN THE DISPLAY AGE
N M
I +$G(AM)<1 Q $$FMDIFF^XLFDT(DT,AUPNDOB,1)_" days old" ; PATCHED BY GIS 5/7/07
S M=(AM#12)
I AM>35 Q (AM\12)_" years and "_M_" month"_$S(M=1:"",1:"s")
Q AM_" month"_$S(AM=1:"",1:"s")
;
GUI(OUT,IN) ; EP - RPC: VEN WCM GUI REMINDERS; RETURN THE REMINDER LIST
; PATCHED BY GIS 9/5/08
S OUT="NO REMINDERS"
I $D(^DPT($G(IN),0))
E Q
N DFN,APCHSEGH,LINE,CNT,X,Y,Z,%
S DFN=IN,APCHSEGH="BYPASS"
D WCESEG(DFN) I '$O(LINE(2)) Q
S CNT=0,OUT=""
F S CNT=$O(LINE(CNT)) Q:'CNT D
. I $L(OUT) S OUT=OUT_"|"
. I LINE(CNT)["__ " S LINE(CNT)=" "_$E(LINE(CNT),3,999)
. S OUT=OUT_LINE(CNT)
. Q
Q
;
PEGUI(OUT,IN) ; EP - RPC: VEN WCM GET PT ED ; PATIENT ED TOPICS FOR GUI CHECKLIST
I $D(^DPT(+$G(IN),0))
E Q
N DFN,AGE,SEX,SEGIEN,CATIEN,CAT,LINE,X,Y,Z,%,STG,DATA,TOPIC,IEN
S DFN=IN,OUT=""
S STG=$G(^DPT(+$G(DFN),0)) I '$L(STG) Q ; INVALID DFN
S SEX=$S($P(STG,U,2)="M":"Male",$P(STG,U,2)="F":"Female",1:"") ; SEX
S %=$$AM(DFN,.AGE) I 'AGE S AGE=1
S CAT="WCAG",LINE=0,SEGIEN=-1
F S CAT=$O(^VEN(7.11,"B",CAT)) Q:$E(CAT,1,4)'="WCAG" S CATIEN=$O(^VEN(7.11,"B",CAT,0)) Q:'CATIEN D KBI(CATIEN)
I '$O(LINE(1)) Q
S LINE=1,DATA="",HDR=""
F S LINE=$O(LINE(LINE)) Q:'LINE D
. S X=LINE(LINE)
. I $E(X,1,5)'="PT ED",$E(X,1,2)'="__" Q
. I $E(X,1,5)="PT ED" D Q
.. I $E($G(LINE(LINE+1)),1,2)'="__" Q
.. S HDR=X
.. I $L(DATA) S DATA=DATA_"|"
.. S DATA=DATA_HDR
.. Q
. I $E(X,1,2)="__" D
.. S Y=$P(X,". ",2) I Y="" Q
.. S TOPIC=$P(Y,"|") I TOPIC="" Q
.. S IEN=$P(Y,"|",2) I 'IEN Q
.. S DATA=DATA_"\"_TOPIC_"`"_IEN
.. Q
. Q
I $L(DATA) S OUT=DATA
Q
;
PEFLUSH(OUT,IN) ; EP - RPC:VEN WCM FLUSH PT ED
S OUT="PT ED UPDATE FAILED"
I $L($G(IN))
E Q
N X,Y,Z,%,VIEN,USER,TOPIC,SUBTOPIC,MN,TIEN,HDR,DIC,DIE,DR,DLAYGO,LOU,TIME,PECIEN,KBIEN,STG,MAX,PCE,MIN,DFN,B,NOW,UPDATE,STOP
S VIEN=+IN I 'VIEN Q
S B="|"
S DFN=$P($G(^AUPNVSIT(VIEN,0)),U,5) I 'DFN Q
S USER=$P(IN,B,2) I 'USER Q
S TIME=$P(IN,B,3)
S LOU=$P(IN,B,4)
S STG=$P(IN,B,5) I STG="" Q
S NOW=$E($$NOW^XLFDT,1,12)
S MAX=$L(STG,"\"),MIN="",CNT=0
F PCE=1:1:MAX S KBIEN=$P(STG,"\",PCE) I KBIEN D
. S X=$G(^VEN(7.12,KBIEN,0)) I X="" Q
. S SUBTOPIC=$P(X,U,2)
. S MN=$P($G(^VEN(7.12,KBIEN,2)),U,3) I MN="" Q
. S TIEN=0
. F S TIEN=$O(^AUTTEDT("C",MN,TIEN)) Q:'TIEN I '$P($G(^AUTTEDT(TIEN,0)),U,3) Q
. I 'TIEN Q
. I '$D(TOPIC(TIEN)) S CNT=CNT+1
. S TOPIC(TIEN,KBIEN)=SUBTOPIC
. Q
TOPIC I '$O(TOPIC(0)) Q
S MIN=""
I TIME,CNT S MIN=TIME/CNT
I MIN S MIN=$J(MIN,1,0) ; MUST BE AN INTEGER ; PATCHED BY GIS 1/18/2011
S (DIC,DIE)="^AUPNVPED(",DLAYGO=9000010.16,DIC(0)="LO"
S DR=".02////^S X=DFN;.03////^S X=VIEN;.06////^S X=LOU;.08////^S X=MIN;1201////^S X=NOW;1204////^S X=USER;.05////^S X=USER"
S TIEN=0,UPDATE=0
PEF F S TIEN=$O(TOPIC(TIEN)) Q:'TIEN D
. S %=0,STOP=0
. F S %=$O(^AUPNVPED("AD",VIEN,%)) Q:'% I +$G(^AUPNVPED(%,0))=TIEN,$D(^AUPNVPED(%,1)) S UPDATE=1,STOP=1 Q ; A V PTED ENTRY EXISTS FOR THIS VISIT/TOPIC ; WAIT FOR 2ND PASS
. I STOP D ST(%,TIEN) Q
. S X="""`"_TIEN_"""" ; NO V PT ED ENTRIES FOUND FOR THIS VISIT AND TOPIC, SO FORCE NEW ENTRY
. D ^DIC I Y=-1 Q
. S DA=+Y
. L +^AUPNVPED(DA):1 I D ^DIE L -^AUPNVPED(DA)
. D ST(DA,TIEN)
. Q
I UPDATE D UPDATE ; SECOND PASS TO RE-CALC UPDATED FIELDS
D ^XBFMK
S OUT="OK"
Q
;
ST(IEN,TIEN) ; ENTER SUBTOPICS INTO SUBFILE
I $G(IEN),$G(TIEN)
E Q
N DIC,DA,X,KBIEN
S KBIEN=0,DA(1)=IEN,DIC="^AUPNVPED("_DA(1)_",1,",(DLAYGO,DIC("P"))=9000010.161,DIC(0)="LO"
F S KBIEN=$O(TOPIC(TIEN,KBIEN)) Q:'KBIEN D
. S X=TOPIC(TIEN,KBIEN) I X="" Q
. S X=$E(X,1,80)
. D ^DIC
. Q
Q
;
UPDATE ; EP - UPDATE EXISTING V PT ED ENTRIES ; SECOND PASS
N DA,CNT,MIN
S DA=0,CNT=0
F S DA=$O(^AUPNVPED("AD",VIEN,DA)) Q:'DA I $D(^AUPNVPED(DA,1)) S CNT=CNT+1
I 'CNT Q
S DR=".06////^S X=LOU;.08////^S X=MIN;1201////^S X=NOW;1204////^S X=USER;.05////^S X=USER"
S DIE="^AUPNVPED("
S MIN=""
I TIME,CNT S MIN=TIME/CNT
I MIN S MIN=$J(MIN,1,0) ; MUST BE AN INTEGER ; PATCHED BY GIS 1/18/2011
S DA=0
F S DA=$O(^AUPNVPED("AD",VIEN,DA)) Q:'DA I $D(^AUPNVPED(DA,1)) L +^AUPNVPED(DA):1 I D ^DIE L -^AUPNVPED(DA)
Q
;
VENPCCQA ; IHS/OIT/GIS - PRE INSTALL ; HS COMPONENT
+1 ;;2.6;PCC+;**1,2,3**;APR 03, 2012;Build 24
APCHS6B ; IHS/TUCSON/LAB - PART 6 OF APCHS -- SUMMARY PRODUCTION COMPONENTS
+1 ;;2.0;IHS RPMS/PCC Health Summary;;JUN 24, 1997
+2 ;
+3 ; D PEFLUSH(.OUT,"71270|5|10|2|2524\2528\2539") W ! ZW TOPIC Q
+4 ; S AGE=60,SEX="M",LINE=0,DFN=1,SEGIEN=-1 F CATIEN=10:1:26 D KBI(CATIEN)
+5 QUIT
+6 ;
WCE ; ******************** WELL CHILD EXAM * 9000010 *******
+1 NEW LINE,ARR
+2 ; <SETUP>
+3 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF 'APCHSNPG
XECUTE APCHSBRK
+4 ; <DISPLAY>
+5 ; CREATE THE DISPLAY ARRAY
DO WCESEG(APCHSPAT)
+6 ; PRINT THE SEGMENT
DO PRINT
+7 ; <CLEANUP>
CLEANUP KILL APCHSDFN,APCHSN,APCHSICD,APCHSDAT,APCHSNRQ,APCHSICL
+1 QUIT
+2 ;
LINE(STG) ; EP-CREATE A LINE IN THE SEGMENT
+1 SET LINE=LINE+1
+2 SET LINE(LINE)=STG
+3 QUIT
+4 ;
PRINT ; EP-PRINT RESULTS
+1 NEW CNT
+2 SET CNT=0
+3 FOR
SET CNT=$ORDER(LINE(CNT))
IF 'CNT
QUIT
Begin DoDot:1
+4 WRITE !
+5 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+6 SET X=LINE(CNT)
+7 WRITE X
+8 QUIT
End DoDot:1
IF $DATA(APCHSQIT)
QUIT
+9 QUIT
+10 ;
WCESEG(DFN) ; EP - PRINT ALL WELL CHILD REMINDERS AND LAST RESULTS
+1 NEW STG,SEX,AM,DAGE,MOM,X,SEGIEN,DAYS
+2 SET LINE=0
+3 ; INVALID DFN
SET STG=$GET(^DPT(+$GET(DFN),0))
IF '$LENGTH(STG)
QUIT
+4 ; SEX
SET SEX=$SELECT($PIECE(STG,U,2)="M":"Male",$PIECE(STG,U,2)="F":"Female",1:"")
+5 SET MOM=$PIECE($GET(^DPT(DFN,.24)),U,2)
+6 IF MOM=""
SET MOM=$PIECE($GET(^DPT(DFN,.24)),U,3)
+7 IF MOM=""
SET MOM="??"
+8 SET AM=$$AM(DFN,.DAYS)
+9 ; AGE IN MONTHS ; PATCHED BY GIS 5/7/07
IF AM=""
QUIT
+10 IF 'DAYS
SET DAYS=1
+11 ; DISPLAY AGE
SET DAGE=$$DAGE(AM)
IF '$LENGTH(DAGE)
QUIT
+12 ; INTRO DATA LINE
SET X=SEX_" "_DAGE_" Mother: "_MOM
DO LINE(X)
+13 ; SEGMENT NAME MUST EXIST
IF '$LENGTH($GET(APCHSEGH))
QUIT
+14 IF APCHSEGH="BYPASS"
SET SEGIEN=0
+15 ; SEMENT IEN
IF '$TEST
SET SEGIEN=$ORDER(^APCHSCMP("B",$GET(APCHSEGH),0))
IF 'SEGIEN
QUIT
WCE1 ; GET REMINDERS FOR EA KB CATEGORY
DO REM(DFN,SEGIEN,SEX,DAYS)
+1 DO LINE(" ")
+2 QUIT
+3 ;
REM(DFN,SEGIEN,SEX,DAYS) ; EP - REMINDERS
+1 NEW CATIEN,KBIEN,CAT,K,HDR,AGE,ARR,X,CNT,TOT,STG,ORD,CIEN,KTYPE,KIEN,MOD,PEIEN
+2 NEW START,STOP,TITLE,TOT,DOM,ORD,DNAME,DORD,D
+3 SET AGE=$GET(DAYS)
IF 'AGE
QUIT
+4 ; SCREEN BY SEX
SET SEX=$EXTRACT(SEX)
+5 SET DOM=0
+6 FOR
SET DOM=$ORDER(^VEN(7.13,DOM))
IF 'DOM
QUIT
Begin DoDot:1
+7 SET %=$GET(^VEN(7.13,DOM,0))
IF '$LENGTH(%)
QUIT
+8 ; SKIP INACTIVE DOMAINE
IF '$PIECE(%,U,7)
QUIT
+9 SET DNAME=$PIECE(%,U)
+10 SET DORD=$PIECE(%,U,5)
+11 IF 'DORD
SET DORD=100+(DOM*5)
+12 SET CAT=0
+13 ; CREATE THE ORDINAL ARRAY
FOR
SET CAT=$ORDER(^VEN(7.13,DOM,1,CAT))
IF 'CAT
QUIT
Begin DoDot:2
+14 SET %=$GET(^VEN(7.13,DOM,1,CAT,0))
+15 SET CATIEN=+%
IF 'CATIEN
QUIT
+16 SET ORD=$PIECE(%,U,2)
+17 ; MAKE SURE EVERY CAT HAS AN ORDER - EVEN IF ONE IS NOT OFFICIALLY ASSIGNED
IF 'ORD
SET ORD=100+CAT
+18 SET ORD(DORD,ORD)=CATIEN
+19 QUIT
End DoDot:2
+20 QUIT
End DoDot:1
+21 SET DORD=0
+22 FOR
SET DORD=$ORDER(ORD(DORD))
IF 'DORD
QUIT
Begin DoDot:1
+23 SET ORD=0
+24 FOR
SET ORD=$ORDER(ORD(DORD,ORD))
IF 'ORD
QUIT
SET CATIEN=ORD(DORD,ORD)
DO KBI(CATIEN)
+25 QUIT
End DoDot:1
+26 QUIT
+27 ;
KBI(CATIEN) ; EP - GET KB ITEMS
+1 NEW LASTLINE,ARR
+2 SET K=$GET(^VEN(7.11,CATIEN,0))
IF '$LENGTH(K)
QUIT
+3 ; CATEGORY HEADER
SET HDR=$PIECE(K,U,9)
+4 ; TYPE OF KB ITEM: PT ED, DEVEL, SCREENING, ETC.
SET KTYPE=$PIECE(K,U,11)
+5 ; SET THE SPACER AND HEADER LINES FOR THIS CATEGORY OF ITEMS
DO LINE(" ")
DO LINE(HDR)
+6 SET LASTLINE=LINE
+7 SET KIEN=0
SET TOT=0
KILL ARR
+8 ; CHECK EA. ENTRY IN THE KNOWLEDGE CATEGORY
FOR
SET KIEN=$ORDER(^VEN(7.12,"B",CATIEN,KIEN))
IF 'KIEN
QUIT
Begin DoDot:1
+9 SET STG=$GET(^VEN(7.12,KIEN,0))
IF '$LENGTH(STG)
QUIT
+10 ; INACTIVE ITEM
IF $PIECE(STG,U,11)
QUIT
+11 SET START=$PIECE(STG,U,5)
IF AGE<START
QUIT
+12 SET STOP=$PIECE(STG,U,6)
IF AGE>STOP
QUIT
+13 SET %=$PIECE(STG,U,10)
IF $LENGTH(%)
IF %'=SEX
QUIT
+14 SET TITLE=$PIECE(STG,U,2)
IF '$LENGTH(TITLE)
QUIT
+15 SET MOD=$PIECE(STG,U,12)
+16 IF $LENGTH(MOD)
SET TITLE=TITLE_" ("_MOD_")"
+17 ; STORE DEV ITEM LINES IN TEMP ARRAY FOR SORTING AND QUIT HERE
IF MOD
IF KTYPE=2
SET ARR(MOD)="__ "_TITLE
QUIT
+18 ; PROCEED IF SECONDARY SORTING IS NOT REQUIRED
+19 SET TOT(CATIEN)=$GET(TOT(CATIEN))+1
+20 IF $LENGTH($TEXT(LAST^VENPCCK))
DO LAST^VENPCCK(CATIEN,KIEN,DFN,.TITLE)
+21 SET X="__ "_TOT(CATIEN)_". "_TITLE
+22 ; HIJACKED PROCESS SO APPEND ITEM IEN
IF $GET(SEGIEN)=-1
SET X=X_"|"_KIEN
+23 ; SET THE ITEM NODE
DO LINE(X)
+24 QUIT
End DoDot:1
+25 ; SORT BY %ILE
IF $DATA(ARR)
Begin DoDot:1
+26 SET MOD=999
+27 FOR
SET MOD=$ORDER(ARR(MOD),-1)
IF MOD=""
QUIT
SET X=ARR(MOD)
DO LINE(X)
+28 KILL ARR
+29 QUIT
End DoDot:1
NOITEMS IF LINE'=LASTLINE
QUIT
+1 SET LINE=LINE-2
+2 ; NOTHING FOUND UNDER THIS KB CATEGORY SO REMOVER CAT HEADER
KILL LINE(LINE+1),LINE(LINE+2)
+3 QUIT
+4 ;
AM(DFN,DAYS) ; EP - GIVEN A DFN, RETURN THE PTS CURRENT AGE IN MONTHS
+1 NEW DOB,DIFF,MD,YD,DD,M
+2 SET DOB=$PIECE($GET(^DPT(DFN,0)),U,3)
IF 'DOB
QUIT ""
+3 ; INVALID DOB
IF DOB>DT
QUIT ""
+4 SET (DAYS,D)=$$FMDIFF^XLFDT(DT,DOB,1)
+5 IF D<8
QUIT 0
+6 IF D<15
QUIT .25
+7 IF D<22
QUIT .5
+8 IF D<29
QUIT .75
+9 SET YD=$EXTRACT(DT,1,3)-$EXTRACT(DOB,1,3)
+10 SET MD=$EXTRACT(DT,4,5)-$EXTRACT(DOB,4,5)
+11 SET DD=$EXTRACT(DT,6,7)-$EXTRACT(DOB,6,7)
+12 IF DD<0
SET MD=MD-1
+13 IF MD<1
SET MD=MD+12
SET YD=YD-1
+14 SET M=MD+(YD*12)
+15 IF M<2
QUIT 1
+16 QUIT M
+17 ;
DAGE(AM) ; EP - GIVEN AN AGE IN MONTHS, RETURN THE DISPLAY AGE
+1 NEW M
+2 ; PATCHED BY GIS 5/7/07
IF +$GET(AM)<1
QUIT $$FMDIFF^XLFDT(DT,AUPNDOB,1)_" days old"
+3 SET M=(AM#12)
+4 IF AM>35
QUIT (AM\12)_" years and "_M_" month"_$SELECT(M=1:"",1:"s")
+5 QUIT AM_" month"_$SELECT(AM=1:"",1:"s")
+6 ;
GUI(OUT,IN) ; EP - RPC: VEN WCM GUI REMINDERS; RETURN THE REMINDER LIST
+1 ; PATCHED BY GIS 9/5/08
+2 SET OUT="NO REMINDERS"
+3 IF $DATA(^DPT($GET(IN),0))
+4 IF '$TEST
QUIT
+5 NEW DFN,APCHSEGH,LINE,CNT,X,Y,Z,%
+6 SET DFN=IN
SET APCHSEGH="BYPASS"
+7 DO WCESEG(DFN)
IF '$ORDER(LINE(2))
QUIT
+8 SET CNT=0
SET OUT=""
+9 FOR
SET CNT=$ORDER(LINE(CNT))
IF 'CNT
QUIT
Begin DoDot:1
+10 IF $LENGTH(OUT)
SET OUT=OUT_"|"
+11 IF LINE(CNT)["__ "
SET LINE(CNT)=" "_$EXTRACT(LINE(CNT),3,999)
+12 SET OUT=OUT_LINE(CNT)
+13 QUIT
End DoDot:1
+14 QUIT
+15 ;
PEGUI(OUT,IN) ; EP - RPC: VEN WCM GET PT ED ; PATIENT ED TOPICS FOR GUI CHECKLIST
+1 IF $DATA(^DPT(+$GET(IN),0))
+2 IF '$TEST
QUIT
+3 NEW DFN,AGE,SEX,SEGIEN,CATIEN,CAT,LINE,X,Y,Z,%,STG,DATA,TOPIC,IEN
+4 SET DFN=IN
SET OUT=""
+5 ; INVALID DFN
SET STG=$GET(^DPT(+$GET(DFN),0))
IF '$LENGTH(STG)
QUIT
+6 ; SEX
SET SEX=$SELECT($PIECE(STG,U,2)="M":"Male",$PIECE(STG,U,2)="F":"Female",1:"")
+7 SET %=$$AM(DFN,.AGE)
IF 'AGE
SET AGE=1
+8 SET CAT="WCAG"
SET LINE=0
SET SEGIEN=-1
+9 FOR
SET CAT=$ORDER(^VEN(7.11,"B",CAT))
IF $EXTRACT(CAT,1,4)'="WCAG"
QUIT
SET CATIEN=$ORDER(^VEN(7.11,"B",CAT,0))
IF 'CATIEN
QUIT
DO KBI(CATIEN)
+10 IF '$ORDER(LINE(1))
QUIT
+11 SET LINE=1
SET DATA=""
SET HDR=""
+12 FOR
SET LINE=$ORDER(LINE(LINE))
IF 'LINE
QUIT
Begin DoDot:1
+13 SET X=LINE(LINE)
+14 IF $EXTRACT(X,1,5)'="PT ED"
IF $EXTRACT(X,1,2)'="__"
QUIT
+15 IF $EXTRACT(X,1,5)="PT ED"
Begin DoDot:2
+16 IF $EXTRACT($GET(LINE(LINE+1)),1,2)'="__"
QUIT
+17 SET HDR=X
+18 IF $LENGTH(DATA)
SET DATA=DATA_"|"
+19 SET DATA=DATA_HDR
+20 QUIT
End DoDot:2
QUIT
+21 IF $EXTRACT(X,1,2)="__"
Begin DoDot:2
+22 SET Y=$PIECE(X,". ",2)
IF Y=""
QUIT
+23 SET TOPIC=$PIECE(Y,"|")
IF TOPIC=""
QUIT
+24 SET IEN=$PIECE(Y,"|",2)
IF 'IEN
QUIT
+25 SET DATA=DATA_"\"_TOPIC_"`"_IEN
+26 QUIT
End DoDot:2
+27 QUIT
End DoDot:1
+28 IF $LENGTH(DATA)
SET OUT=DATA
+29 QUIT
+30 ;
PEFLUSH(OUT,IN) ; EP - RPC:VEN WCM FLUSH PT ED
+1 SET OUT="PT ED UPDATE FAILED"
+2 IF $LENGTH($GET(IN))
+3 IF '$TEST
QUIT
+4 NEW X,Y,Z,%,VIEN,USER,TOPIC,SUBTOPIC,MN,TIEN,HDR,DIC,DIE,DR,DLAYGO,LOU,TIME,PECIEN,KBIEN,STG,MAX,PCE,MIN,DFN,B,NOW,UPDATE,STOP
+5 SET VIEN=+IN
IF 'VIEN
QUIT
+6 SET B="|"
+7 SET DFN=$PIECE($GET(^AUPNVSIT(VIEN,0)),U,5)
IF 'DFN
QUIT
+8 SET USER=$PIECE(IN,B,2)
IF 'USER
QUIT
+9 SET TIME=$PIECE(IN,B,3)
+10 SET LOU=$PIECE(IN,B,4)
+11 SET STG=$PIECE(IN,B,5)
IF STG=""
QUIT
+12 SET NOW=$EXTRACT($$NOW^XLFDT,1,12)
+13 SET MAX=$LENGTH(STG,"\")
SET MIN=""
SET CNT=0
+14 FOR PCE=1:1:MAX
SET KBIEN=$PIECE(STG,"\",PCE)
IF KBIEN
Begin DoDot:1
+15 SET X=$GET(^VEN(7.12,KBIEN,0))
IF X=""
QUIT
+16 SET SUBTOPIC=$PIECE(X,U,2)
+17 SET MN=$PIECE($GET(^VEN(7.12,KBIEN,2)),U,3)
IF MN=""
QUIT
+18 SET TIEN=0
+19 FOR
SET TIEN=$ORDER(^AUTTEDT("C",MN,TIEN))
IF 'TIEN
QUIT
IF '$PIECE($GET(^AUTTEDT(TIEN,0)),U,3)
QUIT
+20 IF 'TIEN
QUIT
+21 IF '$DATA(TOPIC(TIEN))
SET CNT=CNT+1
+22 SET TOPIC(TIEN,KBIEN)=SUBTOPIC
+23 QUIT
End DoDot:1
TOPIC IF '$ORDER(TOPIC(0))
QUIT
+1 SET MIN=""
+2 IF TIME
IF CNT
SET MIN=TIME/CNT
+3 ; MUST BE AN INTEGER ; PATCHED BY GIS 1/18/2011
IF MIN
SET MIN=$JUSTIFY(MIN,1,0)
+4 SET (DIC,DIE)="^AUPNVPED("
SET DLAYGO=9000010.16
SET DIC(0)="LO"
+5 SET DR=".02////^S X=DFN;.03////^S X=VIEN;.06////^S X=LOU;.08////^S X=MIN;1201////^S X=NOW;1204////^S X=USER;.05////^S X=USER"
+6 SET TIEN=0
SET UPDATE=0
PEF FOR
SET TIEN=$ORDER(TOPIC(TIEN))
IF 'TIEN
QUIT
Begin DoDot:1
+1 SET %=0
SET STOP=0
+2 ; A V PTED ENTRY EXISTS FOR THIS VISIT/TOPIC ; WAIT FOR 2ND PASS
FOR
SET %=$ORDER(^AUPNVPED("AD",VIEN,%))
IF '%
QUIT
IF +$GET(^AUPNVPED(%,0))=TIEN
IF $DATA(^AUPNVPED(%,1))
SET UPDATE=1
SET STOP=1
QUIT
+3 IF STOP
DO ST(%,TIEN)
QUIT
+4 ; NO V PT ED ENTRIES FOUND FOR THIS VISIT AND TOPIC, SO FORCE NEW ENTRY
SET X="""`"_TIEN_""""
+5 DO ^DIC
IF Y=-1
QUIT
+6 SET DA=+Y
+7 LOCK +^AUPNVPED(DA):1
IF $TEST
DO ^DIE
LOCK -^AUPNVPED(DA)
+8 DO ST(DA,TIEN)
+9 QUIT
End DoDot:1
+10 ; SECOND PASS TO RE-CALC UPDATED FIELDS
IF UPDATE
DO UPDATE
+11 DO ^XBFMK
+12 SET OUT="OK"
+13 QUIT
+14 ;
ST(IEN,TIEN) ; ENTER SUBTOPICS INTO SUBFILE
+1 IF $GET(IEN)
IF $GET(TIEN)
+2 IF '$TEST
QUIT
+3 NEW DIC,DA,X,KBIEN
+4 SET KBIEN=0
SET DA(1)=IEN
SET DIC="^AUPNVPED("_DA(1)_",1,"
SET (DLAYGO,DIC("P"))=9000010.161
SET DIC(0)="LO"
+5 FOR
SET KBIEN=$ORDER(TOPIC(TIEN,KBIEN))
IF 'KBIEN
QUIT
Begin DoDot:1
+6 SET X=TOPIC(TIEN,KBIEN)
IF X=""
QUIT
+7 SET X=$EXTRACT(X,1,80)
+8 DO ^DIC
+9 QUIT
End DoDot:1
+10 QUIT
+11 ;
UPDATE ; EP - UPDATE EXISTING V PT ED ENTRIES ; SECOND PASS
+1 NEW DA,CNT,MIN
+2 SET DA=0
SET CNT=0
+3 FOR
SET DA=$ORDER(^AUPNVPED("AD",VIEN,DA))
IF 'DA
QUIT
IF $DATA(^AUPNVPED(DA,1))
SET CNT=CNT+1
+4 IF 'CNT
QUIT
+5 SET DR=".06////^S X=LOU;.08////^S X=MIN;1201////^S X=NOW;1204////^S X=USER;.05////^S X=USER"
+6 SET DIE="^AUPNVPED("
+7 SET MIN=""
+8 IF TIME
IF CNT
SET MIN=TIME/CNT
+9 ; MUST BE AN INTEGER ; PATCHED BY GIS 1/18/2011
IF MIN
SET MIN=$JUSTIFY(MIN,1,0)
+10 SET DA=0
+11 FOR
SET DA=$ORDER(^AUPNVPED("AD",VIEN,DA))
IF 'DA
QUIT
IF $DATA(^AUPNVPED(DA,1))
LOCK +^AUPNVPED(DA):1
IF $TEST
DO ^DIE
LOCK -^AUPNVPED(DA)
+12 QUIT
+13 ;
