VENPCC2 ; IHS/OIT/GIS - HEALTH SUMMARY GENERATOR ;
;;2.6;PCC+;;NOV 12, 2007
;
; DEAD CODE IN VER 2.2
;
HS(APCHSPAT,APCHSTYP,VISIT,DEPTIEN) ; EP-GENERATE A HEALTH SUMMARY
N PATH2,PATH3
I $D(^AUPNPAT(+$G(APCHSPAT),0)),$D(^APCHSCTL(+$G(APCHSTYP),0)),$D(^VEN(7.95,+$G(DEPTIEN),0))
E Q
I '$L($T(EN1^APCHS)) N ERR S ERR="Missing APCHS/APCHS0 patches. Can't print health summary!" D ERR^VENPCC1(ERR) Q
S %=$G(^VEN(7.5,+$G(CFIGIEN),2)) I %="" D ERR7^VENPCC1 Q
S PATH2=%,%=$G(^VEN(7.5,+$G(CFIGIEN),3)) I %="" D ERR7^VENPCC1 Q
S PATH3=%
NEW NEW %,%FN,%I,%T,%Y,APCHSFNM,APCHSIC,APCHSICD,APCHSICL,APCHSIR,APCHSNRQ,APCHSPDN,APCHSSGY,APCHSMTY,APCHSTAT,ARRAY,FILE,HEAD,I,POP,STOP,TAB,TMP,X,Y,APCHSERR,APCHSBWR
S TMP="^TMP(""VEN HS"",$J)",FILE="T"_VISIT_".TXT" K @TMP
S IOST="P-PRINTER",IOSL=99999,IOM=80
S POP=$$OPN^VENPCCP(PATH3,FILE,"W","N IO S IO=DEV D EN1^APCHS") K ^TMP($J,"APCHSMED") I POP Q
S POP=$$OPN^VENPCCP(PATH3,FILE,"R","D LINE^VENPCC2") I POP Q
D DEL^VENPCCP(PATH3,("T"_VISIT_".TXT")) ; CLEAN UP THE TMP FILE
PASS ; FIRST PASS THROUGH THE ARRAY
NEW %,I,PATIENT,SCNT,SNO,STOP,X
S SCNT=0
S %=$G(@TMP@(0,2)) I '$L(%) S ERR="Unable to generate health summary. Directory may be full!" D ERR^VENPCC1(ERR) Q ; /usr directory or descendent is full
S %=$P(%,"** ",2),%=$P(%," **") S @TMP@(2,"H1")=%
S %=$P(@TMP@(0,3),"** ",2),@TMP@(2,"H2")=" "_$P(%,"pg")
S @TMP@(2,"HEADER")="HS",@TMP@(2,"TEMPLATE")="HS2",@TMP@(2,"PRINTER")=""
; S %=$$PGRP^VENPCCU(DEPTIEN,1,$G(PGRP)) I %="" D ERR2^VENPCC1 Q
; S @TMP@(2,"GROUP")=%
S (%,PATIENT)=$P($G(^DPT(APCHSPAT,0)),U) I '$L(%) D ERR3^VENPCC1 S STOP=1 Q
S X=$P(%,",",2,99)_" "_$P(%,",")
I $G(DFN),$G(DEPTIEN) S X=X_" #"_$$CHART^VENPCC1A(DEPTIEN,DFN)
S @TMP@(2,"FOOTER")=X
S I=0 F S I=$O(@TMP@(0,I)) Q:'I S X=^(I) D
. I X["** END" K @TMP@(0,I-1),^(I),^(I+1)
. I X[("**"_$E(PATIENT,1,20)) K @TMP@(0,I) Q
. I X["CONFIDENTIAL PATIENT" K @TMP@(0,I) Q
. I $L(X)>50,$E(X)="-",$E(X,$L(X))="-" S %=$$STRIP(X) S @TMP@(1,I)=% K @TMP@(0,I-1),^(I+1)
. Q
S SNO=0 F S SNO=$O(@TMP@(1,SNO)) Q:'SNO D SEC(SNO) I $G(STOP) Q
D EXP
K @TMP
D AUDIT(APCHSPAT,DUZ,$G(DEPTIEN),$G(VISIT))
Q
;
LINE F I=1:1 R X:30 Q:$$STATUS^%ZISH!(X["** END ") S @TMP@(0,I)=X
Q
;
SEC(SNO) ; EP-PROCESS A SECTION
NEW %,COMP,INO,NAME,REF,X,Y,LINE,LNO
S NAME=@TMP@(1,SNO),COMP=$P(NAME," (")
S SCNT=SCNT+1
SEC1 S @TMP@(2,("S"_SCNT))=NAME,INO=0,LNO=SNO
F S LNO=$O(@TMP@(0,LNO)) Q:'LNO S LINE=^(LNO) Q:LINE["--- " D SET^VENPCC2($C(9)_LINE)
D SET($C(9))
Q
;
SET(X) ; EP-SAVE TMP GLOBALS
I X[U S X=$TR(X,U,"")
S INO=INO+1
I INO>50 S:INO=51 @TMP@(2,("S"_(SCNT*100+50)))="<<Space constraints prevent display of additional lines in this section!!!>>" Q
S @TMP@(2,("S"_(SCNT*100+INO)))=X
Q
;
EXP ; EXPORT THE MAIL MERGE FILE
NEW %,%FN,FILE,I,LINE,LNO,NAME,X,Y,Z,PATH
S @TMP@(3,1)="HEADER",^(2)="TEMPLATE",^(3)="GROUP",^(4)="PRINTER",^(5)="H1",^(6)="H2"
S I=6 F X=1:1:25 F Y=1:1:50 D
. I Y=1 S I=I+1,@TMP@(3,I)="S"_X,Z=X*100
. S I=I+1,@TMP@(3,I)="S"_(Z+Y)
. Q
S @TMP@(3,I+1)="FOOTER"
N HSFLAG S HSFLAG=1
D TCP^VENPCC1 ; TCP PRINT SERVICE
Q
;
AUDIT(PAT,USER,SITE,VISIT) ; EP-AUDIT FILE
NEW %,%DT,%I,%Q,%Y,D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y,DLAYGO
D NOW^%DTC S X=%
S DIC="^VEN(7.8,",DIC(0)="L",DLAYGO=19707.8 D ^DIC
I Y=-1 Q
S DIE=DIC,DA=+Y
S DR=".02////^ S X=$G(PAT);.03////^S X=$G(SITE);.04////^S X=USER"
I '$G(VFLAG),$L($G(VISIT)),'$G(NOVISIT) S DR=DR_";.05////^S X=VISIT"
I $G(APPDATE) S DR=DR_";.06////^S X=APPDATE"
L +^VEN(7.8):0 I $T D ^DIE L -^VEN(7.8)
Q
;
STRIP(X) ;
S X=$P(X," ",2,999)
S X=$RE(X)
S X=$P(X," ",2,999)
S X=$RE(X)
Q X
;
VENPCC2 ; IHS/OIT/GIS - HEALTH SUMMARY GENERATOR ;
+1 ;;2.6;PCC+;;NOV 12, 2007
+2 ;
+3 ; DEAD CODE IN VER 2.2
+4 ;
HS(APCHSPAT,APCHSTYP,VISIT,DEPTIEN) ; EP-GENERATE A HEALTH SUMMARY
+1 NEW PATH2,PATH3
+2 IF $DATA(^AUPNPAT(+$GET(APCHSPAT),0))
IF $DATA(^APCHSCTL(+$GET(APCHSTYP),0))
IF $DATA(^VEN(7.95,+$GET(DEPTIEN),0))
+3 IF '$TEST
QUIT
+4 IF '$LENGTH($TEXT(EN1^APCHS))
NEW ERR
SET ERR="Missing APCHS/APCHS0 patches. Can't print health summary!"
DO ERR^VENPCC1(ERR)
QUIT
+5 SET %=$GET(^VEN(7.5,+$GET(CFIGIEN),2))
IF %=""
DO ERR7^VENPCC1
QUIT
+6 SET PATH2=%
SET %=$GET(^VEN(7.5,+$GET(CFIGIEN),3))
IF %=""
DO ERR7^VENPCC1
QUIT
+7 SET PATH3=%
NEW NEW %,%FN,%I,%T,%Y,APCHSFNM,APCHSIC,APCHSICD,APCHSICL,APCHSIR,APCHSNRQ,APCHSPDN,APCHSSGY,APCHSMTY,APCHSTAT,ARRAY,FILE,HEAD,I,POP,STOP,TAB,TMP,X,Y,APCHSERR,APCHSBWR
+1 SET TMP="^TMP(""VEN HS"",$J)"
SET FILE="T"_VISIT_".TXT"
KILL @TMP
+2 SET IOST="P-PRINTER"
SET IOSL=99999
SET IOM=80
+3 SET POP=$$OPN^VENPCCP(PATH3,FILE,"W","N IO S IO=DEV D EN1^APCHS")
KILL ^TMP($JOB,"APCHSMED")
IF POP
QUIT
+4 SET POP=$$OPN^VENPCCP(PATH3,FILE,"R","D LINE^VENPCC2")
IF POP
QUIT
+5 ; CLEAN UP THE TMP FILE
DO DEL^VENPCCP(PATH3,("T"_VISIT_".TXT"))
PASS ; FIRST PASS THROUGH THE ARRAY
+1 NEW %,I,PATIENT,SCNT,SNO,STOP,X
+2 SET SCNT=0
+3 ; /usr directory or descendent is full
SET %=$GET(@TMP@(0,2))
IF '$LENGTH(%)
SET ERR="Unable to generate health summary. Directory may be full!"
DO ERR^VENPCC1(ERR)
QUIT
+4 SET %=$PIECE(%,"** ",2)
SET %=$PIECE(%," **")
SET @TMP@(2,"H1")=%
+5 SET %=$PIECE(@TMP@(0,3),"** ",2)
SET @TMP@(2,"H2")=" "_$PIECE(%,"pg")
+6 SET @TMP@(2,"HEADER")="HS"
SET @TMP@(2,"TEMPLATE")="HS2"
SET @TMP@(2,"PRINTER")=""
+7 ; S %=$$PGRP^VENPCCU(DEPTIEN,1,$G(PGRP)) I %="" D ERR2^VENPCC1 Q
+8 ; S @TMP@(2,"GROUP")=%
+9 SET (%,PATIENT)=$PIECE($GET(^DPT(APCHSPAT,0)),U)
IF '$LENGTH(%)
DO ERR3^VENPCC1
SET STOP=1
QUIT
+10 SET X=$PIECE(%,",",2,99)_" "_$PIECE(%,",")
+11 IF $GET(DFN)
IF $GET(DEPTIEN)
SET X=X_" #"_$$CHART^VENPCC1A(DEPTIEN,DFN)
+12 SET @TMP@(2,"FOOTER")=X
+13 SET I=0
FOR
SET I=$ORDER(@TMP@(0,I))
IF 'I
QUIT
SET X=^(I)
Begin DoDot:1
+14 IF X["** END"
KILL @TMP@(0,I-1),^(I),^(I+1)
+15 IF X[("**"_$EXTRACT(PATIENT,1,20))
KILL @TMP@(0,I)
QUIT
+16 IF X["CONFIDENTIAL PATIENT"
KILL @TMP@(0,I)
QUIT
+17 IF $LENGTH(X)>50
IF $EXTRACT(X)="-"
IF $EXTRACT(X,$LENGTH(X))="-"
SET %=$$STRIP(X)
SET @TMP@(1,I)=%
KILL @TMP@(0,I-1),^(I+1)
+18 QUIT
End DoDot:1
+19 SET SNO=0
FOR
SET SNO=$ORDER(@TMP@(1,SNO))
IF 'SNO
QUIT
DO SEC(SNO)
IF $GET(STOP)
QUIT
+20 DO EXP
+21 KILL @TMP
+22 DO AUDIT(APCHSPAT,DUZ,$GET(DEPTIEN),$GET(VISIT))
+23 QUIT
+24 ;
LINE FOR I=1:1
READ X:30
IF $$STATUS^%ZISH!(X["** END ")
QUIT
SET @TMP@(0,I)=X
+1 QUIT
+2 ;
SEC(SNO) ; EP-PROCESS A SECTION
+1 NEW %,COMP,INO,NAME,REF,X,Y,LINE,LNO
+2 SET NAME=@TMP@(1,SNO)
SET COMP=$PIECE(NAME," (")
+3 SET SCNT=SCNT+1
SEC1 SET @TMP@(2,("S"_SCNT))=NAME
SET INO=0
SET LNO=SNO
+1 FOR
SET LNO=$ORDER(@TMP@(0,LNO))
IF 'LNO
QUIT
SET LINE=^(LNO)
IF LINE["--- "
QUIT
DO SET^VENPCC2($CHAR(9)_LINE)
+2 DO SET($CHAR(9))
+3 QUIT
+4 ;
SET(X) ; EP-SAVE TMP GLOBALS
+1 IF X[U
SET X=$TRANSLATE(X,U,"")
+2 SET INO=INO+1
+3 IF INO>50
IF INO=51
SET @TMP@(2,("S"_(SCNT*100+50)))="<<Space constraints prevent display of additional lines in this section!!!>>"
QUIT
+4 SET @TMP@(2,("S"_(SCNT*100+INO)))=X
+5 QUIT
+6 ;
EXP ; EXPORT THE MAIL MERGE FILE
+1 NEW %,%FN,FILE,I,LINE,LNO,NAME,X,Y,Z,PATH
+2 SET @TMP@(3,1)="HEADER"
SET ^(2)="TEMPLATE"
SET ^(3)="GROUP"
SET ^(4)="PRINTER"
SET ^(5)="H1"
SET ^(6)="H2"
+3 SET I=6
FOR X=1:1:25
FOR Y=1:1:50
Begin DoDot:1
+4 IF Y=1
SET I=I+1
SET @TMP@(3,I)="S"_X
SET Z=X*100
+5 SET I=I+1
SET @TMP@(3,I)="S"_(Z+Y)
+6 QUIT
End DoDot:1
+7 SET @TMP@(3,I+1)="FOOTER"
+8 NEW HSFLAG
SET HSFLAG=1
+9 ; TCP PRINT SERVICE
DO TCP^VENPCC1
+10 QUIT
+11 ;
AUDIT(PAT,USER,SITE,VISIT) ; EP-AUDIT FILE
+1 NEW %,%DT,%I,%Q,%Y,D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y,DLAYGO
+2 DO NOW^%DTC
SET X=%
+3 SET DIC="^VEN(7.8,"
SET DIC(0)="L"
SET DLAYGO=19707.8
DO ^DIC
+4 IF Y=-1
QUIT
+5 SET DIE=DIC
SET DA=+Y
+6 SET DR=".02////^ S X=$G(PAT);.03////^S X=$G(SITE);.04////^S X=USER"
+7 IF '$GET(VFLAG)
IF $LENGTH($GET(VISIT))
IF '$GET(NOVISIT)
SET DR=DR_";.05////^S X=VISIT"
+8 IF $GET(APPDATE)
SET DR=DR_";.06////^S X=APPDATE"
+9 LOCK +^VEN(7.8):0
IF $TEST
DO ^DIE
LOCK -^VEN(7.8)
+10 QUIT
+11 ;
STRIP(X) ;
+1 SET X=$PIECE(X," ",2,999)
+2 SET X=$REVERSE(X)
+3 SET X=$PIECE(X," ",2,999)
+4 SET X=$REVERSE(X)
+5 QUIT X
+6 ;
