source: FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDFN2.m@ 649

Last change on this file since 649 was 628, checked in by George Lilly, 16 years ago

initial load of FOIAVistA 6/30/08 version
File size: 5.1 KB
Line 
1IBDFN2 ;ALB/CJM - ENCOUNTER FORM - INTERFACE ROUTINES ;NOV 16,1992
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;**29,31,36,43**;APR 24, 1997
3APPT ;returns appt date@time^date^time
4 N Y
5 S Y="" I IBAPPT S Y=IBAPPT K %DT D DD^%DT
6 S @IBARY=Y_"^"_$P(Y,"@")_"^"_$P(Y,"@",2)
7 Q
8NOW ;returns date and time
9 ;FORMATS:
10 ; MMM DD, YYYY@HH:MM:SS at the "IB DATE@TIME" subscript
11 ; MMM DD,YYYY at the "IB DATE" subscript
12 ; HH:MM:SS at the "IB TIME" subscript
13 N Y,%,%H,%I,X
14 D NOW^%DTC S Y=% K %DT D DD^%DT
15 S ^TMP("IB",$J,"INTERFACES",+$G(DFN),"IB CURRENT DATE@TIME")=Y
16 S ^TMP("IB",$J,"INTERFACES",+$G(DFN),"IB CURRENT TIME")=$P(Y,"@",2)
17 S ^TMP("IB",$J,"INTERFACES",+$G(DFN),"IB CURRENT DATE")=$P(Y,"@")
18 Q
19 ;
20SPSEMPLR ;returns spouse's employer,address, telephone
21 ;input variables - DFN
22 N ARY,CNT S CNT=1
23 S ARY="^TMP(""IB"",$J,""INTERFACES"",+$G(DFN))"
24 S VAOA("A")=6 D OAD^VADPT
25 I VAERR S (@ARY@("DPT SPOUSE'S EMPLOYER NAME"),@ARY@("DPT SPOUSE'S EMPLOYER TELEPHONE"),@ARY@("DPT SPOUSE'S EMPLOYER ADDRESS LINES"))="" Q
26 I VAOA(1)'="" S @ARY@("DPT SPOUSE'S EMPLOYER ADDRESS LINES",CNT)=VAOA(1),CNT=CNT+1
27 I VAOA(2)'="" S @ARY@("DPT SPOUSE'S EMPLOYER ADDRESS LINES",CNT)=VAOA(2),CNT=CNT+1
28 I VAOA(3)'="" S @ARY@("DPT SPOUSE'S EMPLOYER ADDRESS LINES",CNT)=VAOA(3),CNT=CNT+1
29 S @ARY@("DPT SPOUSE'S EMPLOYER ADDRESS LINES",CNT)=VAOA(4)_", "_$P(VAOA(5),"^",2)_" "_VAOA(6)
30 S @ARY@("DPT SPOUSE'S EMPLOYER TELEPHONE")=VAOA(8)
31 S @ARY@("DPT SPOUSE'S EMPLOYER NAME")=VAOA(9)
32 K VAOA,VAERR
33 Q
34EMPLOYER ;returns employer,address, telephone
35 ;input variables - DFN
36 N ARY,CNT S CNT=1
37 S ARY="^TMP(""IB"",$J,""INTERFACES"",DFN)"
38 S VAOA("A")=5 D OAD^VADPT
39 I VAERR S (@ARY@("DPT PATIENT'S EMPLOYER NAME"),@ARY@("DPT PATIENT'S EMPLOYER TELEPHONE"),@ARY@("DPT PATIENT'S EMPLOYER ADDRESS LINES"))="" Q
40 I VAOA(1)'="" S @ARY@("DPT PATIENT'S EMPLOYER ADDRESS LINES",CNT)=VAOA(1),CNT=CNT+1
41 I VAOA(2)'="" S @ARY@("DPT PATIENT'S EMPLOYER ADDRESS LINES",CNT)=VAOA(2),CNT=CNT+1
42 I VAOA(3)'="" S @ARY@("DPT PATIENT'S EMPLOYER ADDRESS LINES",CNT)=VAOA(3),CNT=CNT+1
43 S @ARY@("DPT PATIENT'S EMPLOYER ADDRESS LINES",CNT)=VAOA(4)_", "_$P(VAOA(5),"^",2)_" "_VAOA(6)
44 S @ARY@("DPT PATIENT'S EMPLOYER TELEPHONE")=VAOA(8)
45 S @ARY@("DPT PATIENT'S EMPLOYER NAME")=VAOA(9)
46 K VAOA,VAERR
47 Q
48MT ;returns means test data
49 N Y,RET,GET
50 S GET=$$LST^DGMTU(DFN)
51 S RET=$P(GET,"^",3)_"^"
52 S Y=$P(GET,"^",2) D DD^%DT
53 S RET=RET_Y_"^"_$P(GET,"^",4)
54 S @IBARY=RET
55 Q
56ENROLL ;returns enrollment priority code and copay information
57 ;
58 N IBEP,IBEP1
59 ; --get enrollment priority code
60 S IBEP=$$PRIORITY^DGENA(DFN)
61 ;
62 ; --get copay information (yes or not)
63 S IBEP1=$$BIL^DGMTUB(DFN,DT)
64 S $P(IBEP,"^",2)=$S(IBEP1=1:"Y",1:"N")
65 S @IBARY=IBEP
66 Q
67ALLERGY ;outputs a list of the patient's allergies
68 ;piece #1=allergy name,#2=type of allergy(FOOD/DRUG/OTHER),#3=type of allergy(F/D/O),#4=VERFIED?(YES/NO),#5=TRUE ALLERGEN(YES/NO)
69 N GMRA,GMRAL,NODE,I,COUNT,TYPE
70 D:$L($T(GMRADPT^GMRADPT)) ^GMRADPT
71 I GMRAL=0 S COUNT=1,@IBARY@(COUNT)="NKA" Q
72 S (COUNT,I)=0 F S I=$O(GMRAL(I)) Q:'I D
73 .S COUNT=COUNT+1
74 .S NODE=$G(GMRAL(I))
75 .S TYPE=$P(NODE,"^",3)
76 .S @IBARY@(COUNT)=$P(NODE,"^",2)_"^"_$S(TYPE="D":"DRUG",TYPE="F":"FOOD",TYPE="O":"OTHER",1:"")_"^"_TYPE_"^"_$S($P(NODE,"^",4)=1:"YES",1:"NO")_"^"_$S($P(NODE,"^",5)=0:"YES",$P(NODE,"^",5)=1:"NO",1:"")
77 Q
78 ;
79PRMT ; -- print a 1010f if required or will expire in 357.09;.1 days
80 ; called from print manger
81 ; requires dfn, ibappt=appointment date
82 ;
83 N IBDMT,IBDMT1,IBDMT2,DGMTI,DGMTDT,DGMTYPT,DGOPT
84 S IBDMT1=$$LST^DGMTU(DFN,DT,1) ; means test
85 S IBDMT2=$$LST^DGMTU(DFN,DT,2) ; copay test
86 I IBDMT2="",IBDMT1="" G PRMTQ
87 S IBDMT=$S(IBDMT2="":IBDMT1,IBDMT1="":IBDMT2,$P(IBDMT1,"^",2)'<$P(IBDMT2,"^",2):IBDMT1,1:IBDMT2)
88 S DGMTYPT=$S(IBDMT=IBDMT2:2,1:1) ; set type of test
89 S DGMTI=+IBDMT,DGMTDT=$P(IBDMT,"^",2)
90 S DGOPT=1 ;pretend were from registration, don't close device when done
91 S STATUS=$P(IBDMT,"^",4)
92 I $S(STATUS="R":0,STATUS="N":1,STATUS="L":1,STATUS="I":0,$$FMDIFF^XLFDT(IBAPPT,DGMTDT,1)>(365-$S($P($G(^IBD(357.09,1,0)),"^",10):$P(^(0),"^",10),1:30)):0,1:1) G PRMTQ ;not required within params
93 ;
94 I STATUS="R" D GETMT I IBDMT1="" Q
95 D START^DGMTP
96PRMTQ Q
97 ;
98GETMT ;Since status is required find last valid means test
99 ;
100 S IBDMT=$$LVMT^DGMTU(DFN,DT) ; means test
101 S DGMTYPT=1 ; set type of test
102 S DGMTI=+IBDMT,DGMTDT=$P(IBDMT,"^",2)
103 Q
104 ;
105 ;
106MSTSTAT ;-- Get patient's MST status for EF display block
107 ; Input:
108 ; DFN
109 ;
110 ; Output:
111 ; Calls API $$GETSTAT^DGMSTAPI(DFN):
112 ; Piece 1 -- MST Status Code (Y, N, D, or U)
113 ; Piece 2 -- MST Status Description
114 ;
115 N ARY,MST
116 S ARY="^TMP(""IB"",$J,""INTERFACES"",DFN)"
117 I '$G(DFN) Q
118 S MST=$$GETSTAT^DGMSTAPI(DFN)
119 I +MST=0!(+MST>0) S @ARY@("DGMST STATUS")=$P(MST,"^",2)_"^"_$S(+MST>0:$P(MST,"^",6),1:"Unknown, not screened")
120 Q
121 ;
122 ;
123ASKMST ;-- Ask if patient's treatment is related to SC and MST (if applicable)
124 ;
125 N ARY,COUNT
126 Q:'$G(DFN)
127 S ARY="^TMP(""IB"",$J,""INTERFACES"")"
128 S COUNT=1
129 I $$SC^SDCO22(DFN,0) S @ARY@("DGMST SELECT MST CLASSIFICATN",COUNT)="SC^Was treatment for an SC condition?",COUNT=COUNT+1
130 I $$MST^SDCO22(DFN,0) S @ARY@("DGMST SELECT MST CLASSIFICATN",COUNT)="MST^Was treatment related to MST? (Ask provider only)"
131 Q
Note: See TracBrowser for help on using the repository browser.