ACHSRP3 ; IHS/ITSC/PMF - PRINT CHS (43 & 64) FORMS (1/2) ; [ 10/16/2001 8:16 AM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
;
S T=0,E(8)=ACHSCOPT,ACHSSF="",LS=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0)),U,6),ACHSLCA=$P(^(0),U,7),ACHSTYPE=$P(^(0),U,2)
;
S:+LS>0 ACHSSF="S"_LS
S:+ACHSLCA>0 ACHSSF="C"_ACHSLCA
I ACHSTYPE="S" S E(11)=E(7),X=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0)),U),E(7)=$E(X,4,5)_"-"_$E(X,6,7)_"-"_$E(X,2,3)
;D KILLNULS
TESTPRNT ;EP. (For test print.)
PONUM ;
W:'T !
;IF PARAM 'PRINT 3 DIGIT TYPE' IS YES
;
W !?ACHSTAB+53,$S($$PARM^ACHS(2,20)="Y":$S(ACHSTYPV=1:323,ACHSTYPV=2:324,1:325),1:""),?ACHSTAB+60+$S(ACHSTYPV=1:2,1:0),"0",ACHSORDN,ACHSSF
DCR ;
;IF PARM 'PRINT DCR # ON P.O.
I $$PARM^ACHS(2,18)="Y" W " (",ACHSDCR,")"
ORDOFF ;
W !!?ACHSTAB+42+T,B(1)
FACHRN ;
W !
W:$D(A(1)) ?ACHSTAB,A(1)
ORDADRS1 ;
W:$D(B(2)) ?ACHSTAB+42+T,B(2)
NAME ;
W !
W:$D(A(2)) ?ACHSTAB,A(2)
SSV ;
;RETURN SSN VERIFICATION
I $G(DFN) S X=$$SSV^ACHSTX3(DFN) I "PVX"[X W ?ACHSTAB+28,X
ORDADRS2 ;
W:$D(B(3)) ?ACHSTAB+42+T,B(3)
SUCODE ;
W:$D(B(4)) ?69,"(",B(4),")"
PATADRS ;
W !
W:$D(A(3)) ?ACHSTAB,A(3)
AGESEX ;
W !?ACHSTAB
W:$D(A(4)) A(4)," "
COMCODE ;
W:$D(A(5)) A(5)
PROVIDER ;
W:$D(D(1)) ?ACHSTAB+42+T,D(1)
PROADRS1 ;
W !
W:$D(D(2)) ?ACHSTAB+42+T,D(2)
W !
DOS ;
W:$D(A(6)) ?ACHSTAB,A(6)
PROADRS2 ;
W:$D(D(3)) ?ACHSTAB+42+T,D(3)
FROMTO ;
W !
W:$D(C(4)) ?ACHSTAB,C(4)
PTYPE ;
;PRINT VENDOR TYPE?
I $$PARM^ACHS(2,17)="Y",$D(D(7)) W ?ACHSTAB+39+T,D(7)
EIN ;
W:$D(D(4)) ?ACHSTAB+42+T,D(4)
DESC ;
W !
W:$D(A(7)) ?ACHSTAB,A(7)
S ACHSARCO=$P($G(^ACHSF(DUZ(2),0)),U,11) ;AREA CONTRACTING NO.
I F(6)'["Open Market",'$F("235^239^241^242^243^244^245^246^247^248^249^285",$E(F(6),1,3)) S F(6)=ACHSARCO_"-"_F(6)
;
CNTCANOB ;
W !?ACHSTAB,"SCC: ",$G(F(8)) ; ACHS*3*1 IHS/ADC/GTH 11-20-97 Printing SCC had been removed. NEVER COMMENTED OUT
S:T T=2
F I=6,7,9 W ?ACHSTAB+$P("^^^^^42^58^^67",U,I)+T,$G(F(I)) I T S T=T-1
W !!!?ACHSTAB,ACHSSIG
S T=$S(ACHSTYPV=1:"32^41^62^70",1:"32^41^52^62")
DTOPTAMT ;
F I=7:1:9 W:$D(E(I)) ?ACHSTAB+$P(T,U,I-6),E(I) I I=8,ACHSTYPV=1 W ?ACHSTAB+54,ACHSESDA
HSPORDNO ;
W:$D(E(10)) ?ACHSTAB+$P(T,U,4),E(10)
W !!!!!!!!!!!
S I=$O(^ACHS(4,0))
G CSUPL:ACHSDEST'="F",CSUPL:'I,CSUPL:'$D(^ACHS(4,I,0))
W ?20,"PLEASE MAIL IHS-",$S(ACHSTYPV=1:"43",ACHSTYPV=3:"64",1:"")," AND COMPLETED HCFA-",$S(ACHSTYPV=1:"1450",ACHSTYPV=3:"1500",1:"")," TO:",!!?25,$P(^ACHS(4,I,0),U) W:$P(^(0),U,6)]"" !?25,$P(^(0),U,6)
W !?25,$P(^ACHS(4,I,0),U,2),!?25,$P(^(0),U,3)
W ", ",$P(^DIC(5,$P(^ACHS(4,I,0),U,4),0),U,2)," ",$P(^ACHS(4,I,0),U,5)
CSUPL ;
I ACHSTYPE="C"!(ACHSTYPE="S") D CSUPLA G END
G END:$D(ACHSTPRT)!'$D(A(9))
D ^ACHSRP31
END ;
W @IOF
Q
;
CSUPLA ;EP.
S ACHSTYPE="******** "_$S(ACHSTYPE="C":"CANCELLATION ********",1:"SUPPLEMENT TO P.O. DATED "_E(11))
W !!
F I=1:1:5 W ?25,ACHSTYPE,! I I=4,ACHSTYPE["CANCEL" S ACHSTYPE="CANCELLATION DATE "_$$FMTE^XLFDT($$TRAN^ACHS(0,1))
Q
;
KILLNULS ;EP.
F ACHSX="A","B","C","D","E","F" F ACHSY=1:1:12 S ACHS=ACHSX_"("_ACHSY_")" I $D(@ACHS),'$L(@ACHS) K @ACHS
K ACHSX,ACHSY
Q
;
ACHSRP3 ; IHS/ITSC/PMF - PRINT CHS (43 & 64) FORMS (1/2) ; [ 10/16/2001 8:16 AM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
+2 ;
+3 SET T=0
SET E(8)=ACHSCOPT
SET ACHSSF=""
SET LS=$PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0)),U,6)
SET ACHSLCA=$PIECE(^(0),U,7)
SET ACHSTYPE=$PIECE(^(0),U,2)
+4 ;
+5 IF +LS>0
SET ACHSSF="S"_LS
+6 IF +ACHSLCA>0
SET ACHSSF="C"_ACHSLCA
+7 IF ACHSTYPE="S"
SET E(11)=E(7)
SET X=$PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0)),U)
SET E(7)=$EXTRACT(X,4,5)_"-"_$EXTRACT(X,6,7)_"-"_$EXTRACT(X,2,3)
+8 ;D KILLNULS
TESTPRNT ;EP. (For test print.)
PONUM ;
+1 IF 'T
WRITE !
+2 ;IF PARAM 'PRINT 3 DIGIT TYPE' IS YES
+3 ;
+4 WRITE !?ACHSTAB+53,$SELECT($$PARM^ACHS(2,20)="Y":$SELECT(ACHSTYPV=1:323,ACHSTYPV=2:324,1:325),1:""),?ACHSTAB+60+$SELECT(ACHSTYPV=1:2,1:0),"0",ACHSORDN,ACHSSF
DCR ;
+1 ;IF PARM 'PRINT DCR # ON P.O.
+2 IF $$PARM^ACHS(2,18)="Y"
WRITE " (",ACHSDCR,")"
ORDOFF ;
+1 WRITE !!?ACHSTAB+42+T,B(1)
FACHRN ;
+1 WRITE !
+2 IF $DATA(A(1))
WRITE ?ACHSTAB,A(1)
ORDADRS1 ;
+1 IF $DATA(B(2))
WRITE ?ACHSTAB+42+T,B(2)
NAME ;
+1 WRITE !
+2 IF $DATA(A(2))
WRITE ?ACHSTAB,A(2)
SSV ;
+1 ;RETURN SSN VERIFICATION
+2 IF $GET(DFN)
SET X=$$SSV^ACHSTX3(DFN)
IF "PVX"[X
WRITE ?ACHSTAB+28,X
ORDADRS2 ;
+1 IF $DATA(B(3))
WRITE ?ACHSTAB+42+T,B(3)
SUCODE ;
+1 IF $DATA(B(4))
WRITE ?69,"(",B(4),")"
PATADRS ;
+1 WRITE !
+2 IF $DATA(A(3))
WRITE ?ACHSTAB,A(3)
AGESEX ;
+1 WRITE !?ACHSTAB
+2 IF $DATA(A(4))
WRITE A(4)," "
COMCODE ;
+1 IF $DATA(A(5))
WRITE A(5)
PROVIDER ;
+1 IF $DATA(D(1))
WRITE ?ACHSTAB+42+T,D(1)
PROADRS1 ;
+1 WRITE !
+2 IF $DATA(D(2))
WRITE ?ACHSTAB+42+T,D(2)
+3 WRITE !
DOS ;
+1 IF $DATA(A(6))
WRITE ?ACHSTAB,A(6)
PROADRS2 ;
+1 IF $DATA(D(3))
WRITE ?ACHSTAB+42+T,D(3)
FROMTO ;
+1 WRITE !
+2 IF $DATA(C(4))
WRITE ?ACHSTAB,C(4)
PTYPE ;
+1 ;PRINT VENDOR TYPE?
+2 IF $$PARM^ACHS(2,17)="Y"
IF $DATA(D(7))
WRITE ?ACHSTAB+39+T,D(7)
EIN ;
+1 IF $DATA(D(4))
WRITE ?ACHSTAB+42+T,D(4)
DESC ;
+1 WRITE !
+2 IF $DATA(A(7))
WRITE ?ACHSTAB,A(7)
+3 ;AREA CONTRACTING NO.
SET ACHSARCO=$PIECE($GET(^ACHSF(DUZ(2),0)),U,11)
+4 IF F(6)'["Open Market"
IF '$FIND("235^239^241^242^243^244^245^246^247^248^249^285",$EXTRACT(F(6),1,3))
SET F(6)=ACHSARCO_"-"_F(6)
+5 ;
CNTCANOB ;
+1 ; ACHS*3*1 IHS/ADC/GTH 11-20-97 Printing SCC had been removed. NEVER COMMENTED OUT
WRITE !?ACHSTAB,"SCC: ",$GET(F(8))
+2 IF T
SET T=2
+3 FOR I=6,7,9
WRITE ?ACHSTAB+$PIECE("^^^^^42^58^^67",U,I)+T,$GET(F(I))
IF T
SET T=T-1
+4 WRITE !!!?ACHSTAB,ACHSSIG
+5 SET T=$SELECT(ACHSTYPV=1:"32^41^62^70",1:"32^41^52^62")
DTOPTAMT ;
+1 FOR I=7:1:9
IF $DATA(E(I))
WRITE ?ACHSTAB+$PIECE(T,U,I-6),E(I)
IF I=8
IF ACHSTYPV=1
WRITE ?ACHSTAB+54,ACHSESDA
HSPORDNO ;
+1 IF $DATA(E(10))
WRITE ?ACHSTAB+$PIECE(T,U,4),E(10)
+2 WRITE !!!!!!!!!!!
+3 SET I=$ORDER(^ACHS(4,0))
+4 IF ACHSDEST'="F"
GOTO CSUPL
IF 'I
GOTO CSUPL
IF '$DATA(^ACHS(4,I,0))
GOTO CSUPL
+5 WRITE ?20,"PLEASE MAIL IHS-",$SELECT(ACHSTYPV=1:"43",ACHSTYPV=3:"64",1:"")," AND COMPLETED HCFA-",$SELECT(ACHSTYPV=1:"1450",ACHSTYPV=3:"1500",1:"")," TO:",!!?25,$PIECE(^ACHS(4,I,0),U)
IF $PIECE(^(0),U,6)]""
WRITE !?25,$PIECE(^(0),U,6)
+6 WRITE !?25,$PIECE(^ACHS(4,I,0),U,2),!?25,$PIECE(^(0),U,3)
+7 WRITE ", ",$PIECE(^DIC(5,$PIECE(^ACHS(4,I,0),U,4),0),U,2)," ",$PIECE(^ACHS(4,I,0),U,5)
CSUPL ;
+1 IF ACHSTYPE="C"!(ACHSTYPE="S")
DO CSUPLA
GOTO END
+2 IF $DATA(ACHSTPRT)!'$DATA(A(9))
GOTO END
+3 DO ^ACHSRP31
END ;
+1 WRITE @IOF
+2 QUIT
+3 ;
CSUPLA ;EP.
+1 SET ACHSTYPE="******** "_$SELECT(ACHSTYPE="C":"CANCELLATION ********",1:"SUPPLEMENT TO P.O. DATED "_E(11))
+2 WRITE !!
+3 FOR I=1:1:5
WRITE ?25,ACHSTYPE,!
IF I=4
IF ACHSTYPE["CANCEL"
SET ACHSTYPE="CANCELLATION DATE "_$$FMTE^XLFDT($$TRAN^ACHS(0,1))
+4 QUIT
+5 ;
KILLNULS ;EP.
+1 FOR ACHSX="A","B","C","D","E","F"
FOR ACHSY=1:1:12
SET ACHS=ACHSX_"("_ACHSY_")"
IF $DATA(@ACHS)
IF '$LENGTH(@ACHS)
KILL @ACHS
+2 KILL ACHSX,ACHSY
+3 QUIT
+4 ;
