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

DGPTR0.m

Go to the documentation of this file.
  1. DGPTR0 ;MJK/JS/ADL/TJ,HIOFO/FT - PTF TRANSMISSION ;4/21/15 11:28am
  1. ;;5.3;Registration;**114,247,338,342,510,524,565,678,729,664,850,884**;Aug 13, 1993;Build 31
  1. ;;ADL;Update for CSV Project;;Mar 27, 2003
  1. ;
  1. ; ICDXCODE APIs - #5699
  1. ; SDCO22 APIs - #1579
  1. ;
  1. ; -- setup control data
  1. ; ssn
  1. S X=$P(DG10,U,9),Y=$S($E(X,10)="P":"P",1:" ")_$E(X_" ",1,9)
  1. ; -- adm d/t
  1. S X=$P($P(DG0,U,2),"."),Y=Y_$E(X,4,5)_$E(X,6,7)_$E(X,2,3)_$E($P($P(DG0,U,2),".",2)_"0000",1,4)
  1. ; -- facility #
  1. S L=3,X=DG0,Z=3 D ENTER S Y=Y_$E($P(X,U,5)_" ",1,3)
  1. S DGHEAD=Y,Y=" "_Y D HEAD^DGPTR1
  1. ;
  1. 101 ; -- setup 101 transmission
  1. ; control data and name
  1. S Y=$S(T1:"C",1:"N")_"101"_DGHEAD S Y=Y_$$PTFNMFT($P(DG10,U))
  1. ; source of admission
  1. S Y=Y_$S($D(^DIC(45.1,+DG101,0)):$J($P(^(0),U,1),2),1:" ")
  1. ; xfring fac and suffix
  1. S L=3,X=DG101,Z=5 D ENTER S Y=Y_$E($P(X,U,6)_" ",1,3)
  1. ; source of payment
  1. S Y=Y_$S("A0"[$P(DG0,U,5):" ",1:$J($P(DG101,U,3),1))
  1. ;POW Location
  1. S Y=Y_$S($P(DG52,U,5)="N":1,$P(DG52,U,5)'="Y":3,$P(DG52,U,6)>0&($P(DG52,U,6)<7):3+$P(DG52,U,6),$P(DG52,U,6)>6&($P(DG52,U,6)<9):$C($P(DG52,U,6)+58),1:" ")
  1. ;marital status, sex
  1. S Y=Y_$S($D(^DIC(11,+$P(DG10,U,5),0)):$E(^(0),1),1:" ")_$J($P(DG10,U,2),1)
  1. ; date of birth
  1. S DGDOB=$P(DG10,U,3)\1,Y=Y_$E(DGDOB,4,5)_$E(DGDOB,6,7)_(1700+$E(DGDOB,1,3))
  1. ; period of service
  1. S DGPOS=$S($D(^DIC(21,+$P(DG32,U,3),0)):$P(^(0),U,3),1:"")
  1. I $D(^DGPM(+$O(^DGPM("APTF",J,0)),"ODS")),+^("ODS") S DGPOS=6
  1. ;-- if non vet admitting eligibility make POS 9
  1. S DGPOS=$$CKPOS^DGPTUTL($P($G(^DGPT(PTF,101)),U,8),DGPOS)
  1. S X=DGPOS,Z=1,L=2 D ENTER
  1. ; agent orange
  1. S G=" " S DGAO=$P(DG321,U,2) S:DGPOS=7 G=$S($P(DG321,U)'="Y":1,DGAO="N":2,DGAO="Y":3,1:4) S:(DGAO="Y")&($P(DG321,U,13)="K") G=5
  1. ; rad exposure
  1. S E=" " I "^0^2^4^5^7^8^Z^"[(U_DGPOS_U) S DGNT=$P(DG321,U,12),E=$S($P(DG321,U,3)'="Y":1,DGNT="N":2,DGNT="T":3,DGNT="B":4,1:" ")
  1. S Y=Y_G_E K DGPOS,G,E
  1. ; state code
  1. S X=$S($D(^DIC(5,+$P(DG11,U,5),0)):^(0),1:""),L=2,Z=3 D ENTER0
  1. ; county code
  1. S X=$S($D(^DIC(5,+$P(DG11,U,5),1,+$P(DG11,U,7),0)):^(0),1:""),L=3,Z=3 D ENTER0
  1. ; zip code
  1. S X=DG11,Z=6,L=5 D ENTER
  1. ; means test
  1. S Y=Y_$S($P(DG70,U,26)="Y":"AS",1:$E($P(DG0,U,10)_" ",1,2))
  1. ; income
  1. I $L($P(DG101,U,7))>6 S Y=Y_"999999"
  1. E S X=DG101,Z=7,L=6 D ENTER0
  1. ;MST
  1. S X=$$GETSTAT^DGMSTAPI(+DG0) S Y=Y_$S(X<0:"U",1:$P(X,"^",2))
  1. ;Combat Vet
  1. S X=$$CVEDT^DGCV(+DG0,$P(DG0,"^",2)) S Y=Y_$S((+X)>0:1,1:0)
  1. S X=$P(X,"^",2)_" " S Y=Y_$E(X,4,5)_$E(X,6,7)_$E(X,2,3)
  1. ;Project 112/SHAD
  1. S X=$$SHAD^SDCO22(+DG0) S Y=Y_$S((+X)>0:1,1:0)
  1. ;Emergency Response Indicator
  1. S X=$$EMGRES^DGUTL(+DG0) S Y=Y_$S("^K^"[(U_X_U):X,1:" ")
  1. ;Country Code
  1. S X=$$GET1^DIQ(779.004,$P(DG11,U,10)_",",.01),Z=1,L=3 D ENTER
  1. D FILL^DGPTR2,SAVE
  1. ;I T1 S Y=$E(Y,1,52)_" "_$E(Y,54,125)
  1. I T1 S $E(Y,53)=" " ;sets $E(Y,53)=" " if census, but why after it is saved?
  1. ;
  1. P401 ; -- setup 401P transaction
  1. G 401:'$D(^DGPT(J,"401P"))!(T1) S DG41=^("401P"),Y=$S(T1:"C",1:"N")_"401"_DGHEAD_"P"_" "
  1. N EFFDATE,IMPDATE,DGPTDAT D EFFDATE^DGPTIC10(J)
  1. S DG41=$S($D(^DGPT(J,"401P")):^("401P"),1:"")
  1. S L=1 F K=1:1:5 S:'$P(DG41,U,K) DG41=$P(DG41,U,1,K-1)_U_$P(DG41,U,K+1,99),K=K-1 S L=L+1 Q:L=5
  1. F I=1:1:5 S DGPTTMP=$$ICDDATA^ICDXCODE("PROC",+$P(DG41,U,I),EFFDATE,"I"),Y=Y_$S(+DGPTTMP>0:$J($P($P(DGPTTMP,U,2),".",1),2)_$E($P($P(DGPTTMP,U,2),".",2)_" ",1,3),1:" ")_" "
  1. K DGPTEDT
  1. I $E(Y,40)'=" " D FILL^DGPTR2,SAVE
  1. ;
  1. 401 ; -- setup 401 transactions
  1. G 501:'$D(^DGPT(J,"S")) K ^UTILITY($J,"S") S I=0
  1. SUR ;
  1. S I=$O(^DGPT(J,"S",I)) G 501:'I S DGSUR=^(I,0),DGAUX=$S($D(^DGPT(J,"S",I,300)):^(300),1:"") G SUR:'DGSUR
  1. G SUR:DGSUR<T1!(DGSUR>T2) S DGSUD=+^(0)\1,^UTILITY($J,"S",DGSUD)=$S($D(^UTILITY($J,"S",DGSUD)):^(DGSUD),1:0)+1,F=$S(DGSUD<2871000:0,1:1)
  1. I ^UTILITY($J,"S",DGSUD)>$S(F:3,1:2) D I Y'=1 S DGERR=1 Q
  1. .W !,"**There are more than ",$S(F:"three",1:"two")," surgeries on the same date**"
  1. .S DIR(0)="Y",DIR("B")="YES",DIR("A")="OK to continue?" D ^DIR K DIR
  1. S Y=$S(T1:"C",1:"N")_"401"_DGHEAD_$E(DGSUD,4,5)_$E(DGSUD,6,7)_$E(DGSUD,2,3)_$E($P(+DGSUR,".",2)_"0000",1,4)_$S($D(^DIC(45.3,+$P(DGSUR,U,3),0)):$P(^(0),U,1),1:" ")
  1. S L=1,X=DGSUR F Z=4:1:7 D ENTER
  1. N EFFDATE,IMPDATE,DGPTDAT D EFFDATE^DGPTIC10(J)
  1. S L=1 F K=8:1:12 S:'$P(DGSUR,U,K) DGSUR=$P(DGSUR,U,1,K-1)_U_$P(DGSUR,U,K+1,99),K=K-1 S L=L+1 Q:L=5
  1. F K=8:1:12 S DGPTTMP=$$ICDDATA^ICDXCODE("PROC",+$P(DGSUR,U,K),EFFDATE,"I"),Y=Y_$S(+DGPTTMP>0:$J($P($P(DGPTTMP,U,2),".",1),2)_$E($P($P(DGPTTMP,U,2),".",2)_" ",1,3),1:" ")_" "
  1. ;
  1. ;-- att phy
  1. S Y=Y_" "
  1. ;-- additional ptf question
  1. ;send null, if disch date>inactive date. DG/729
  1. I +$P($G(^DIC(45.88,1,0)),U,3) S DGAUX=$S((+$G(^DGPT(J,70))<$P(^DIC(45.88,1,0),U,3)):DGAUX,1:"")
  1. S Y=Y_$E($P(DGAUX,U)_" ")
  1. K DGAUX
  1. D FILL^DGPTR2,SAVE G SUR
  1. 501 G 501^DGPTR2
  1. Q
  1. ENTER S Y=Y_$J($P(X,U,Z),L)
  1. Q
  1. ENTER0 S Y=Y_$S($P(X,U,Z)]"":$E("000000",$L($P(X,U,Z))+1,L)_$P(X,U,Z),1:$J($P(X,U,Z),L))
  1. Q
  1. SAVE ;save segment to MailMan message and ^TMP("AEDIT",$J), if data is valid
  1. D SAVE^DGPTR2
  1. Q Q
  1. DGNAM S X=DGNAM I X?.E.P F I=1:1:$L(X) S Z=$E(X,I) Q:Z="," S:Z?.P&(Z]"") X=$E(X,1,I-1)_$E(X,I+1,$L(X)),I=I-1 Q:X'?.E.P
  1. I X?.E.L D UP^DGHELP
  1. S DGNAM=X
  1. Q
  1. ;
  1. PTFNMFT(DG10) ;this function will format the name of the patient for
  1. ; transmission of the 101 record to Austin. In addition, this
  1. ; function will be used by OPC so that the format will be consistent
  1. ; for OPC and PTF.
  1. ; INPUT : DG10 - .01 field from the patient record.
  1. ; OUTPUT: name in the format proper format.
  1. ; A = <12 - characters of last name padded with blanks>
  1. ; B = <1 - first initial of fist name>
  1. ; C = <1 - first initial of middle name>
  1. ; returns :ABC <14 - characters>
  1. N X,I
  1. S DGNAM=DG10 D DGNAM
  1. Q $E($P(DGNAM,",",1)_" ",1,12)_$J($E($P(DGNAM,",",2),1),1)_$J($E($P($P(DGNAM,",",2)," ",2),1),1)