Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: VENPCCQA

VENPCCQA.m

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