source: WorldVistAEHR/trunk/r/DENTAL-DEN/DENTSCR.m@ 1006

Last change on this file since 1006 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.8 KB
Line 
1DENTSCR ; HISC/NCA-Enter Bulk Screening Treatments ;10/4/96 13:58
2 ;;1.2;DENTAL;**21,24**;JAN 26, 1989
3EN1 ; Process Initial Screening Treatment
4 W !!,"Each prompt needs to be filled in order for the treatment to be filed.",!,"To Exit, Enter ""^""."
5 K DIR S DIR(0)="SO^S:Screening;C:Complete Exam",DIR("A")="Select One For Batch Filing" D ^DIR G:$D(DIRUT)!($D(DIROUT)) KIL S DENTBAT=Y
6 K %DT S %DT="AETPX",%DT("A")="DATE/TIME OF TREATMENT: ",%DT("B")="NOW",%DT(0)="-NOW" W ! D ^%DT K %DT S:$D(DTOUT) Y=0 G:Y<1 KIL S DENTDTE=Y
7STA K DIC S DIC="^DENT(225,",DIC(0)="AEMQ" D ^DIC K DIC G KIL:"^"[X!$D(DTOUT),STA:Y<1 S DENTSTA=$P(Y,"^",2)
8PROV K DIC S DIC="^DENT(220.5,",DIC(0)="AEMQ",DIC("S")="I $P(^(0),""^"",2)'="""",'$P(^(0),""^"",3)" D ^DIC K DIC G KIL:"^"[X!$D(DTOUT),PROV:Y<1 S DENTPRV=+Y G:$P(^DENT(220.5,DENTPRV,0),"^",2)="" PROV
9PAT W !,"DENTAL PATIENT: " R X:DTIME G:'$T!(X=U) KIL
10 I X="GROUP" D GROUP G CAT
11 K DIC S DIC="^DENT(220,",DIC(0)="ELMQ" D ^DIC K DIC G KIL:"^"[X!$D(DTOUT),PAT:Y<1 S (DFN,DENTDFN,DENTPAT)=+Y D DEM^VADPT S DENTSSN=$P(VADM(2),"^",1),DENTNAM=$P(VADM(1),"^",1) D KVAR^VADPT
12CAT K DIC S DIC="^DIC(220.2,",DIC(0)="AEMQ",DIC("A")="PATIENT CATEGORY: " D ^DIC K DIC G KIL:"^"[X!$D(DTOUT),CAT:Y<1 S DENTCAT=+Y
13BED K DIC S DIC="^DIC(220.4,",DIC(0)="AEMQ" D ^DIC K DIC G KIL:"^"[X!$D(DTOUT),BED:Y<1 S DENTBED=+Y
14 W !! S DENTCT=0,DENTX=DENTDTE_"^"_DENTSSN_"^"_DENTPRV_"^"_DENTPAT_"^^"_DENTBED_"^"_DENTBAT,$P(DENTX,"^",19)=DENTCAT,$P(DENTX,"^",40)=DENTSTA,$P(DENTX,"^",39)=DENTNAM
15 S $P(DENTX,"^",10)=$P($G(^DENT(220.5,DENTPRV,0)),"^",2)
16 S:$D(DENTGRP) $P(DENTX,"^",26)=DENTGRP
17 S N1=$P(^DENT(221,0),"^",4),N1=N1+1,DENTCT=DENTCT+1
18 W " Treatment Added "
19 K DD,DO D SAVE^DENTCRD(221,DENTX,.DENTDTE)
20 S ^DENT(221,0)=$P(^DENT(221,0),"^",1,2)_"^"_DENTDTE_"^"_N1
21 S DENTSTR=$G(^DENT(221,DENTDTE,0))
22 W !! D REPEAT
23 I DENTCT W !!,"Total ",$S(DENTBAT="S":"Screening",1:"Complete Exam")," Treatment Entered: ",DENTCT
24 G KIL
25REPEAT ; Store Bulk Screening Treatment
26 W ! S DENTX=$G(DENTSTR) D NULL(DENTX,.DENTY)
27 S DENTDAT=$P(DENTY,"^",1) S X=$$CHK(DENTDAT),$P(DENTY,"^",1)=X,DENTDT1=X
28 S N1=$P(^DENT(221,0),"^",4),N1=N1+1,DENTCT=DENTCT+1
29 W " Store Next Treatment "
30 D SAVE^DENTCRD(221,DENTY,.DENTDT1)
31 S ^DENT(221,0)=$P(^DENT(221,0),"^",1,2)_"^"_DENTDT1_"^"_N1
32EDIT1 S E=0 W !! K DIC,DIE S DIE="^DENT(221,",DA=DENTDT1,DR="2;4.5;5" D ^DIE K DIE,DR
33 I $D(Y) S DIK="^DENT(221,",DA=DENTDT1 D ^DIK S DENTCT=DENTCT-1 Q
34 S DENTSTR=$G(^DENT(221,DENTDT1,0)) D CHECK
35 I $P(DENTSTR,"^",39)="" Q
36 G:E EDIT1
37 W ! G REPEAT
38NULL(DENTREC,Y) ; Null the existing fields from Initial Treatment
39 N FLD
40 F FLD=2,4,6,26,39 S $P(DENTREC,"^",FLD)=""
41 S Y=$G(DENTREC)
42 Q
43CHECK ; Check Fields Validity.
44 S DENTCA=$P(DENTSTR,"^",19)
45 I DENTCA="" S E=1 W !,"Patient Category is Missing."
46 I DENTCA<8&(DENTCA'=4)&(DENTCA'=5)&($P(DENTSTR,"^",6)="") S E=1 W *7,!!,"Bed section is missing.",!
47 I $P(DENTSTR,"^",6)'="" I DENTCA>8!(DENTCA=4)!(DENTCA=5) S E=1 W *7,!!,"Bed section must be blank if patient category is OPT, NHC or DOM.",!
48 Q
49CHK(CD) ;FIND A PLACE TO PUT THE NEW RECORD
50 N MO,MD,AD,YR,FL
51 S YR=$E(CD,1,3),MO=$E(CD,4,5),AD=$E(CD,6,7),FL=""
52 S CD=CD+.000001 ; Add a second if date/time exist
53 I $E(CD,13,14)>59 D ; CHECK SECOUNDS
54 .S CD=CD+.000040
55 .I $E(CD,11,12)>59 D ; CHECK MINUTES
56 ..S CD=CD+.004000
57 ..I $E(CD,9,10)>23 D ; CHECK HOURS
58 ...S AD=AD+1,MD=$P($T(DATE),";",MO+2)
59 ...S:+MO=2 MD=MD+$$LEAP^DENTE1(1700+YR)
60 ...I AD>MD D ; CHECK DAYS
61 ....S AD="01",MO=MO+1
62 ....I MO>12 S YR=YR+1,MO="01" ; CHECK MONTH
63 S CD=YR_MO_AD_"."_$P(CD,".",2)
64 Q CD
65GROUP ; Set Group X'Reference
66 S DENTSSN="000000001",DENTGRP=4,DENTPAT="",DENTNAM="GROUP"
67 Q
68DATE ;;31;28;31;30;31;30;31;31;30;31;30;31
69KIL K %,%DT,DA,DIC,DFN,DIE,DENTBED,DENTCA,DENTCAT,DENTPAT,DENTDFN,DENTPAT,DENTCT,DENTDT1,DR,DENTDTE,DENTFLE,DENTNAM,DENTP,DENTREC,DENTSTA,DENTSTR,DENTX,DENTY,DTOUT
70 K DENTBAT,DIR,DENTSSN,DENTGRP,DENTDAT,DENTPRV,DENTZ3,DIK,E,H,I,K,K1,N1,V,X,X1,Y,Z Q
Note: See TracBrowser for help on using the repository browser.