ADEATT ; IHS/HQT/MJL - ATTENDING DDS STMT I ;12:31 PM [ 03/24/1999 9:04 AM ]
;;6.0;ADE;;APRIL 1999
;------->INIT
CTRL S $P(ADELIN,"$",79)="",ADETITL="ATTENDING DENTIST STATEMENT"
S ADEFAST=0,ADEINT=0
;------->PATIENT LOOKUP
S ADENEWVS=0,ADEDIR=1,ADECON=0,AUPNLK("ALL")=""
D PTLOOK G:Y<1 END
VIS ;------->VISIT LOOKUP
D ^ADEGRL2 G:'Y CTRL I ADENEWVS W " ??",*7 G VIS
D HRN^ADEGRL3
;------->LOAD LOCALS
S ADECON=1,ADEDIR=0 D MOD^ADEGRL
;------->LOAD FEES BASED ON ^ADEFEE
INT D FEE^ADEATT2 S ADETCHF=0
D LIST^ADEGRL3
;------->PROMPT FOR CARRIER INFO (ENTER HERE INTERNALLY)
D INS G:Y<1 RET
;------->PROMPT FOR FEES
D ^ADEATT2 G:'Y RET
;------->UPDATE INSURANCE ELIGIBLE FILE
I ADEINSN'["MEDICAID",ADEINSN'["MEDICARE",ADEINSN'["RAILROAD RETIREMENT" D ^ADEATT3
;------->DEVICE SELECTION
S %ZIS="Q" D ^%ZIS G:POP RET I $D(IO("Q")) K IO("Q") D QUE W !,"REQUEST QUEUED." G RET
;------->PRINT STATEMENT
D ^ADEATT4
RET ;------->RETURN
I 'ADEINT D END G CTRL
I ADEINT D ENDINT Q
END ;------->END
D END^ADEGRL
K ADEINS,ADEINSN,ADENOD,ADEINT
Q
PTLOOK ;
K DIC,Y,ADEPAT D ^ADECLS R "Select Dental Patient Name: ",X:DTIME
I '$T!(X="")!(X["^") S Y=-1 Q
I X["?" S XQH="ADE-DVIS-PATIENT" D EN^XQH K XQH G PTLOOK
S DIC="^AUPNPAT(",DIC(0)="MEZQ" D ^DIC K DIC
G:Y<1 PTLOOK
S ADEPAT=$P(Y,U)
S Y=1 Q
INS K DIC,Y R !,"Select INSURER: ",X:DTIME
I '$T!(X="")!(X["^") S Y=-1 Q
S DIC="^AUTNINS(",DIC(0)="MEZQ"
I X["?" S X="?" D ^ADECLS,^DIC R "Press `Return' to continue: ",X:DTIME D LIST^ADEGRL3 G INS
S DIC="^AUTNINS(",DIC(0)="MEZQ"
D ^DIC K DIC
G:Y<1 INS
S ADEINS=+Y,ADEINSN=$P(Y,U,2)
S Y=1 Q
INS2 ;Not allowed to edit the Insurer file
Q
S Y=1 D INS3
I 'ADEDIT S Y=1 Q
W !?5,"Please provide Address information for this insurer (`^' to abort):"
S DIE="^AUTNINS(",DR=".02;.03;.04;.05",DA=ADEINS,DIE("NO^")="OUTOK"
D ^DIE K DR,DIE,DA
D INS3 I ADEDIT S Y=0 W !?5,"***INCOMPLETE INSURER ADDRESS -- ABORTED***" H 1 Q
S Y=1 Q
INS3 S ADEDIT=0 F J=2:1:5 I $P(^AUTNINS(ADEINS,0),U,J)="" S ADEDIT=1
Q
DUZ1 Q
DUZ2 Q
;
QUE S ZTRTN="^ADEATT4",ZTDESC="ATTENDING DDS STATEMENT"
F Z="ADEDES(","ADEINS","ADEINSN","ADEPAT","ADEPNM","ADERDNM","ADERDNMD","ADETCH","ADEV(","ADEVFM" S ZTSAVE(Z)=""
D ^%ZTLOAD
Q
EN ;EP
N ADECON,ADEDIR,ADELIN,ADEFAST,ADETCHF,ADETITL
S ADECON=1,ADEDIR=0,ADEFAST=0,ADEINT=1
S $P(ADELIN,"$",79)="",ADETITL="ATTENDING DENTIST STATEMENT"
G INT
ENDINT S X=0 F J=0:0 S X=$O(ADEV(X)) Q:X="" S $P(ADEV(X),U,3)=""
K ADEDIR,ADECON,ADELIN,ADEFAST,ADETCHF,ADEINT,ADEINS,ADEINSN,ADENOD
Q
ADEATT ; IHS/HQT/MJL - ATTENDING DDS STMT I ;12:31 PM [ 03/24/1999 9:04 AM ]
+1 ;;6.0;ADE;;APRIL 1999
+2 ;------->INIT
CTRL SET $PIECE(ADELIN,"$",79)=""
SET ADETITL="ATTENDING DENTIST STATEMENT"
+1 SET ADEFAST=0
SET ADEINT=0
+2 ;------->PATIENT LOOKUP
+3 SET ADENEWVS=0
SET ADEDIR=1
SET ADECON=0
SET AUPNLK("ALL")=""
+4 DO PTLOOK
IF Y<1
GOTO END
VIS ;------->VISIT LOOKUP
+1 DO ^ADEGRL2
IF 'Y
GOTO CTRL
IF ADENEWVS
WRITE " ??",*7
GOTO VIS
+2 DO HRN^ADEGRL3
+3 ;------->LOAD LOCALS
+4 SET ADECON=1
SET ADEDIR=0
DO MOD^ADEGRL
+5 ;------->LOAD FEES BASED ON ^ADEFEE
INT DO FEE^ADEATT2
SET ADETCHF=0
+1 DO LIST^ADEGRL3
+2 ;------->PROMPT FOR CARRIER INFO (ENTER HERE INTERNALLY)
+3 DO INS
IF Y<1
GOTO RET
+4 ;------->PROMPT FOR FEES
+5 DO ^ADEATT2
IF 'Y
GOTO RET
+6 ;------->UPDATE INSURANCE ELIGIBLE FILE
+7 IF ADEINSN'["MEDICAID"
IF ADEINSN'["MEDICARE"
IF ADEINSN'["RAILROAD RETIREMENT"
DO ^ADEATT3
+8 ;------->DEVICE SELECTION
+9 SET %ZIS="Q"
DO ^%ZIS
IF POP
GOTO RET
IF $DATA(IO("Q"))
KILL IO("Q")
DO QUE
WRITE !,"REQUEST QUEUED."
GOTO RET
+10 ;------->PRINT STATEMENT
+11 DO ^ADEATT4
RET ;------->RETURN
+1 IF 'ADEINT
DO END
GOTO CTRL
+2 IF ADEINT
DO ENDINT
QUIT
END ;------->END
+1 DO END^ADEGRL
+2 KILL ADEINS,ADEINSN,ADENOD,ADEINT
+3 QUIT
PTLOOK ;
+1 KILL DIC,Y,ADEPAT
DO ^ADECLS
READ "Select Dental Patient Name: ",X:DTIME
+2 IF '$TEST!(X="")!(X["^")
SET Y=-1
QUIT
+3 IF X["?"
SET XQH="ADE-DVIS-PATIENT"
DO EN^XQH
KILL XQH
GOTO PTLOOK
+4 SET DIC="^AUPNPAT("
SET DIC(0)="MEZQ"
DO ^DIC
KILL DIC
+5 IF Y<1
GOTO PTLOOK
+6 SET ADEPAT=$PIECE(Y,U)
+7 SET Y=1
QUIT
INS KILL DIC,Y
READ !,"Select INSURER: ",X:DTIME
+1 IF '$TEST!(X="")!(X["^")
SET Y=-1
QUIT
+2 SET DIC="^AUTNINS("
SET DIC(0)="MEZQ"
+3 IF X["?"
SET X="?"
DO ^ADECLS
DO ^DIC
READ "Press `Return' to continue: ",X:DTIME
DO LIST^ADEGRL3
GOTO INS
+4 SET DIC="^AUTNINS("
SET DIC(0)="MEZQ"
+5 DO ^DIC
KILL DIC
+6 IF Y<1
GOTO INS
+7 SET ADEINS=+Y
SET ADEINSN=$PIECE(Y,U,2)
+8 SET Y=1
QUIT
INS2 ;Not allowed to edit the Insurer file
+1 QUIT
+2 SET Y=1
DO INS3
+3 IF 'ADEDIT
SET Y=1
QUIT
+4 WRITE !?5,"Please provide Address information for this insurer (`^' to abort):"
+5 SET DIE="^AUTNINS("
SET DR=".02;.03;.04;.05"
SET DA=ADEINS
SET DIE("NO^")="OUTOK"
+6 DO ^DIE
KILL DR,DIE,DA
+7 DO INS3
IF ADEDIT
SET Y=0
WRITE !?5,"***INCOMPLETE INSURER ADDRESS -- ABORTED***"
HANG 1
QUIT
+8 SET Y=1
QUIT
INS3 SET ADEDIT=0
FOR J=2:1:5
IF $PIECE(^AUTNINS(ADEINS,0),U,J)=""
SET ADEDIT=1
+1 QUIT
DUZ1 QUIT
DUZ2 QUIT
+1 ;
QUE SET ZTRTN="^ADEATT4"
SET ZTDESC="ATTENDING DDS STATEMENT"
+1 FOR Z="ADEDES(","ADEINS","ADEINSN","ADEPAT","ADEPNM","ADERDNM","ADERDNMD","ADETCH","ADEV(","ADEVFM"
SET ZTSAVE(Z)=""
+2 DO ^%ZTLOAD
+3 QUIT
EN ;EP
+1 NEW ADECON,ADEDIR,ADELIN,ADEFAST,ADETCHF,ADETITL
+2 SET ADECON=1
SET ADEDIR=0
SET ADEFAST=0
SET ADEINT=1
+3 SET $PIECE(ADELIN,"$",79)=""
SET ADETITL="ATTENDING DENTIST STATEMENT"
+4 GOTO INT
ENDINT SET X=0
FOR J=0:0
SET X=$ORDER(ADEV(X))
IF X=""
QUIT
SET $PIECE(ADEV(X),U,3)=""
+1 KILL ADEDIR,ADECON,ADELIN,ADEFAST,ADETCHF,ADEINT,ADEINS,ADEINSN,ADENOD
+2 QUIT
